1{-# LANGUAGE GADTs #-} 2 3{-| This module defines the notion of a scope and operations on scopes. 4-} 5module Agda.Syntax.Scope.Base where 6 7import Prelude hiding ( null, length ) 8 9import Control.Arrow (first, second, (&&&)) 10import Control.DeepSeq 11import Control.Monad 12 13import Data.Either (partitionEithers) 14import Data.Foldable ( length, toList ) 15import Data.Function 16import qualified Data.List as List 17import Data.Map (Map) 18import qualified Data.Map as Map 19import Data.Set (Set) 20import qualified Data.Set as Set 21import Data.Maybe 22import Data.Semigroup ( Semigroup(..) ) 23 24import Data.Data (Data) 25 26import GHC.Generics (Generic) 27 28import Agda.Benchmarking 29 30import Agda.Syntax.Position 31import Agda.Syntax.Common 32import Agda.Syntax.Fixity 33import Agda.Syntax.Abstract.Name as A 34import Agda.Syntax.Concrete.Name as C 35import qualified Agda.Syntax.Concrete as C 36import Agda.Syntax.Concrete.Fixity as C 37 38import Agda.Utils.AssocList (AssocList) 39import qualified Agda.Utils.AssocList as AssocList 40import Agda.Utils.Functor 41import Agda.Utils.Lens 42import Agda.Utils.List 43import Agda.Utils.List1 ( List1, pattern (:|) ) 44import qualified Agda.Utils.List1 as List1 45import Agda.Utils.Maybe (filterMaybe) 46import Agda.Utils.Null 47import Agda.Utils.Pretty hiding ((<>)) 48import qualified Agda.Utils.Pretty as P 49import Agda.Utils.Singleton 50import qualified Agda.Utils.Map as Map 51 52import Agda.Utils.Impossible 53 54-- * Scope representation 55 56-- | A scope is a named collection of names partitioned into public and private 57-- names. 58data Scope = Scope 59 { scopeName :: A.ModuleName 60 , scopeParents :: [A.ModuleName] 61 , scopeNameSpaces :: ScopeNameSpaces 62 , scopeImports :: Map C.QName A.ModuleName 63 , scopeDatatypeModule :: Maybe DataOrRecordModule 64 } 65 deriving (Data, Eq, Show, Generic) 66 67data DataOrRecordModule 68 = IsDataModule 69 | IsRecordModule 70 deriving (Data, Show, Eq, Enum, Bounded, Generic) 71 72-- | See 'Agda.Syntax.Common.Access'. 73data NameSpaceId 74 = PrivateNS -- ^ Things not exported by this module. 75 | PublicNS -- ^ Things defined and exported by this module. 76 | ImportedNS -- ^ Things from open public, exported by this module. 77 deriving (Data, Eq, Bounded, Enum, Show, Generic) 78 79allNameSpaces :: [NameSpaceId] 80allNameSpaces = [minBound..maxBound] 81 82type ScopeNameSpaces = [(NameSpaceId, NameSpace)] 83 84localNameSpace :: Access -> NameSpaceId 85localNameSpace PublicAccess = PublicNS 86localNameSpace PrivateAccess{} = PrivateNS 87 88nameSpaceAccess :: NameSpaceId -> Access 89nameSpaceAccess PrivateNS = PrivateAccess Inserted 90nameSpaceAccess _ = PublicAccess 91 92-- | Get a 'NameSpace' from 'Scope'. 93scopeNameSpace :: NameSpaceId -> Scope -> NameSpace 94scopeNameSpace ns = fromMaybe __IMPOSSIBLE__ . lookup ns . scopeNameSpaces 95 96-- | A lens for 'scopeNameSpaces' 97updateScopeNameSpaces :: (ScopeNameSpaces -> ScopeNameSpaces) -> Scope -> Scope 98updateScopeNameSpaces f s = s { scopeNameSpaces = f (scopeNameSpaces s) } 99 100-- | ``Monadic'' lens (Functor sufficient). 101updateScopeNameSpacesM :: 102 (Functor m) => (ScopeNameSpaces -> m ScopeNameSpaces) -> Scope -> m Scope 103updateScopeNameSpacesM f s = for (f $ scopeNameSpaces s) $ \ x -> 104 s { scopeNameSpaces = x } 105 106-- | The complete information about the scope at a particular program point 107-- includes the scope stack, the local variables, and the context precedence. 108data ScopeInfo = ScopeInfo 109 { _scopeCurrent :: A.ModuleName 110 , _scopeModules :: Map A.ModuleName Scope 111 , _scopeVarsToBind :: LocalVars -- ^ The variables that will be bound at the end 112 -- of the current block of variables (i.e. clause). 113 -- We collect them here instead of binding them 114 -- immediately so we can avoid shadowing between 115 -- variables in the same variable block. 116 , _scopeLocals :: LocalVars 117 , _scopePrecedence :: !PrecedenceStack 118 , _scopeInverseName :: NameMap 119 , _scopeInverseModule :: ModuleMap 120 , _scopeInScope :: InScopeSet 121 , _scopeFixities :: C.Fixities -- ^ Maps concrete names C.Name to fixities 122 , _scopePolarities :: C.Polarities -- ^ Maps concrete names C.Name to polarities 123 } 124 deriving (Data, Show, Generic) 125 126-- | For the sake of highlighting, the '_scopeInverseName' map also stores 127-- the 'KindOfName' of an @A.QName@. 128data NameMapEntry = NameMapEntry 129 { qnameKind :: KindOfName -- ^ The 'anameKind'. 130 , qnameConcrete :: List1 C.QName -- ^ Possible renderings of the abstract name. 131 } 132 deriving (Data, Show, Generic) 133 134-- | Invariant: the 'KindOfName' components should be equal 135-- whenever we have to concrete renderings of an abstract name. 136instance Semigroup NameMapEntry where 137 NameMapEntry k xs <> NameMapEntry _ ys = NameMapEntry k (xs <> ys) 138 139type NameMap = Map A.QName NameMapEntry 140type ModuleMap = Map A.ModuleName [C.QName] 141-- type ModuleMap = Map A.ModuleName (List1 C.QName) 142 143instance Eq ScopeInfo where 144 ScopeInfo c1 m1 v1 l1 p1 _ _ _ _ _ == ScopeInfo c2 m2 v2 l2 p2 _ _ _ _ _ = 145 c1 == c2 && m1 == m2 && v1 == v2 && l1 == l2 && p1 == p2 146 147-- | Local variables. 148type LocalVars = AssocList C.Name LocalVar 149 150-- | For each bound variable, we want to know whether it was bound by a 151-- λ, Π, module telescope, pattern, or @let@. 152data BindingSource 153 = LambdaBound -- ^ @λ@ (currently also used for @Π@ and module parameters) 154 | PatternBound -- ^ @f ... =@ 155 | LetBound -- ^ @let ... in@ 156 | WithBound -- ^ @| ... in q@ 157 deriving (Data, Show, Eq, Generic) 158 159instance Pretty BindingSource where 160 pretty = \case 161 LambdaBound -> "local" 162 PatternBound -> "pattern" 163 LetBound -> "let-bound" 164 WithBound -> "with-bound" 165 166-- | A local variable can be shadowed by an import. 167-- In case of reference to a shadowed variable, we want to report 168-- a scope error. 169data LocalVar = LocalVar 170 { localVar :: A.Name 171 -- ^ Unique ID of local variable. 172 , localBindingSource :: BindingSource 173 -- ^ Kind of binder used to introduce the variable (@λ@, @let@, ...). 174 , localShadowedBy :: [AbstractName] 175 -- ^ If this list is not empty, the local variable is 176 -- shadowed by one or more imports. 177 } 178 deriving (Data, Show, Generic) 179 180instance Eq LocalVar where 181 (==) = (==) `on` localVar 182 183instance Ord LocalVar where 184 compare = compare `on` localVar 185 186-- | We show shadowed variables as prefixed by a ".", as not in scope. 187instance Pretty LocalVar where 188 pretty (LocalVar x _ []) = pretty x 189 pretty (LocalVar x _ xs) = "." P.<> pretty x 190 191-- | Shadow a local name by a non-empty list of imports. 192shadowLocal :: [AbstractName] -> LocalVar -> LocalVar 193shadowLocal [] _ = __IMPOSSIBLE__ 194shadowLocal ys (LocalVar x b zs) = LocalVar x b (ys ++ zs) 195 196-- | Treat patternBound variable as a module parameter 197patternToModuleBound :: LocalVar -> LocalVar 198patternToModuleBound x 199 | localBindingSource x == PatternBound = 200 x { localBindingSource = LambdaBound } 201 | otherwise = x 202 203-- | Project name of unshadowed local variable. 204notShadowedLocal :: LocalVar -> Maybe A.Name 205notShadowedLocal (LocalVar x _ []) = Just x 206notShadowedLocal _ = Nothing 207 208-- | Get all locals that are not shadowed __by imports__. 209notShadowedLocals :: LocalVars -> AssocList C.Name A.Name 210notShadowedLocals = mapMaybe $ \ (c,x) -> (c,) <$> notShadowedLocal x 211 212-- | Lenses for ScopeInfo components 213scopeCurrent :: Lens' A.ModuleName ScopeInfo 214scopeCurrent f s = 215 f (_scopeCurrent s) <&> 216 \x -> s { _scopeCurrent = x } 217 218scopeModules :: Lens' (Map A.ModuleName Scope) ScopeInfo 219scopeModules f s = 220 f (_scopeModules s) <&> 221 \x -> s { _scopeModules = x } 222 223scopeVarsToBind :: Lens' LocalVars ScopeInfo 224scopeVarsToBind f s = 225 f (_scopeVarsToBind s) <&> 226 \x -> s { _scopeVarsToBind = x } 227 228scopeLocals :: Lens' LocalVars ScopeInfo 229scopeLocals f s = 230 f (_scopeLocals s) <&> 231 \x -> s { _scopeLocals = x } 232 233scopePrecedence :: Lens' PrecedenceStack ScopeInfo 234scopePrecedence f s = 235 f (_scopePrecedence s) <&> 236 \x -> s { _scopePrecedence = x } 237 238scopeInverseName :: Lens' NameMap ScopeInfo 239scopeInverseName f s = 240 f (_scopeInverseName s) <&> 241 \x -> s { _scopeInverseName = x } 242 243scopeInverseModule :: Lens' ModuleMap ScopeInfo 244scopeInverseModule f s = 245 f (_scopeInverseModule s) <&> 246 \x -> s { _scopeInverseModule = x } 247 248scopeInScope :: Lens' InScopeSet ScopeInfo 249scopeInScope f s = 250 f (_scopeInScope s) <&> 251 \x -> s { _scopeInScope = x } 252 253scopeFixities :: Lens' C.Fixities ScopeInfo 254scopeFixities f s = 255 f (_scopeFixities s) <&> 256 \x -> s { _scopeFixities = x } 257 258scopePolarities :: Lens' C.Polarities ScopeInfo 259scopePolarities f s = 260 f (_scopePolarities s) <&> 261 \x -> s { _scopePolarities = x } 262 263scopeFixitiesAndPolarities :: Lens' (C.Fixities, C.Polarities) ScopeInfo 264scopeFixitiesAndPolarities f s = 265 f' (_scopeFixities s) (_scopePolarities s) <&> 266 \ (fixs, pols) -> s { _scopeFixities = fixs, _scopePolarities = pols } 267 where 268 -- Andreas, 2019-08-18: strict matching avoids space leak, see #1829. 269 f' !fixs !pols = f (fixs, pols) 270 -- Andrea comments on https://github.com/agda/agda/issues/1829#issuecomment-522312084 271 -- on a naive version without the bang patterns: 272 -- 273 -- useScope (because of useR) forces the result of projecting the 274 -- lens, this usually prevents retaining the whole structure when we 275 -- only need a field. However your combined lens adds an extra layer 276 -- of laziness with the pairs, so the actual projections remain 277 -- unforced. 278 -- 279 -- I guess scopeFixitiesAndPolarities could add some strictness when building the pair? 280 281-- | Lens for 'scopeVarsToBind'. 282updateVarsToBind :: (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo 283updateVarsToBind = over scopeVarsToBind 284 285setVarsToBind :: LocalVars -> ScopeInfo -> ScopeInfo 286setVarsToBind = set scopeVarsToBind 287 288-- | Lens for 'scopeLocals'. 289updateScopeLocals :: (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo 290updateScopeLocals = over scopeLocals 291 292setScopeLocals :: LocalVars -> ScopeInfo -> ScopeInfo 293setScopeLocals = set scopeLocals 294 295------------------------------------------------------------------------ 296-- * Name spaces 297-- 298-- Map concrete names to lists of abstract names. 299------------------------------------------------------------------------ 300 301-- | A @NameSpace@ contains the mappings from concrete names that the user can 302-- write to the abstract fully qualified names that the type checker wants to 303-- read. 304data NameSpace = NameSpace 305 { nsNames :: NamesInScope 306 -- ^ Maps concrete names to a list of abstract names. 307 , nsModules :: ModulesInScope 308 -- ^ Maps concrete module names to a list of abstract module names. 309 , nsInScope :: InScopeSet 310 -- ^ All abstract names targeted by a concrete name in scope. 311 -- Computed by 'recomputeInScopeSets'. 312 } 313 deriving (Data, Eq, Show, Generic) 314 315type ThingsInScope a = Map C.Name [a] 316type NamesInScope = ThingsInScope AbstractName 317type ModulesInScope = ThingsInScope AbstractModule 318type InScopeSet = Set A.QName 319 320-- | Set of types consisting of exactly 'AbstractName' and 'AbstractModule'. 321-- 322-- A GADT just for some dependent-types trickery. 323data InScopeTag a where 324 NameTag :: InScopeTag AbstractName 325 ModuleTag :: InScopeTag AbstractModule 326 327-- | Type class for some dependent-types trickery. 328class Ord a => InScope a where 329 inScopeTag :: InScopeTag a 330 331instance InScope AbstractName where 332 inScopeTag = NameTag 333 334instance InScope AbstractModule where 335 inScopeTag = ModuleTag 336 337-- | @inNameSpace@ selects either the name map or the module name map from 338-- a 'NameSpace'. What is selected is determined by result type 339-- (using the dependent-type trickery). 340inNameSpace :: forall a. InScope a => NameSpace -> ThingsInScope a 341inNameSpace = case inScopeTag :: InScopeTag a of 342 NameTag -> nsNames 343 ModuleTag -> nsModules 344 345-- | Non-dependent tag for name or module. 346data NameOrModule = NameNotModule | ModuleNotName 347 deriving (Data, Eq, Ord, Show, Enum, Bounded, Generic) 348 349------------------------------------------------------------------------ 350-- * Decorated names 351-- 352-- - What kind of name? (defined, constructor...) 353-- - Where does the name come from? (to explain to user) 354------------------------------------------------------------------------ 355 356-- | For the sake of parsing left-hand sides, we distinguish 357-- constructor and record field names from defined names. 358 359-- Note: order does matter in this enumeration, see 'isDefName'. 360data KindOfName 361 = ConName -- ^ Constructor name ('Inductive' or don't know). 362 | CoConName -- ^ Constructor name (definitely 'CoInductive'). 363 | FldName -- ^ Record field name. 364 | PatternSynName -- ^ Name of a pattern synonym. 365 | GeneralizeName -- ^ Name to be generalized 366 | DisallowedGeneralizeName -- ^ Generalizable variable from a let open 367 | MacroName -- ^ Name of a macro 368 | QuotableName -- ^ A name that can only be quoted. 369 -- Previous category @DefName@: 370 -- (Refined in a flat manner as Enum and Bounded are not hereditary.) 371 | DataName -- ^ Name of a @data@. 372 | RecName -- ^ Name of a @record@. 373 | FunName -- ^ Name of a defined function. 374 | AxiomName -- ^ Name of a @postulate@. 375 | PrimName -- ^ Name of a @primitive@. 376 | OtherDefName -- ^ A @DefName@, but either other kind or don't know which kind. 377 -- End @DefName@. Keep these together in sequence, for sake of @isDefName@! 378 deriving (Eq, Ord, Show, Data, Enum, Bounded, Generic) 379 380isDefName :: KindOfName -> Bool 381isDefName = (>= DataName) 382 383isConName :: KindOfName -> Maybe Induction 384isConName = \case 385 ConName -> Just Inductive 386 CoConName -> Just CoInductive 387 _ -> Nothing 388 389conKindOfName :: Induction -> KindOfName 390conKindOfName = \case 391 Inductive -> ConName 392 CoInductive -> CoConName 393 394-- | For ambiguous constructors, we might have both alternatives of 'Induction'. 395-- In this case, we default to 'ConName'. 396conKindOfName' :: Foldable t => t Induction -> KindOfName 397conKindOfName' = conKindOfName . approxConInduction 398 399-- | For ambiguous constructors, we might have both alternatives of 'Induction'. 400-- In this case, we default to 'Inductive'. 401approxConInduction :: Foldable t => t Induction -> Induction 402approxConInduction = fromMaybe Inductive . exactConInduction 403 404exactConInduction :: Foldable t => t Induction -> Maybe Induction 405exactConInduction is = case toList is of 406 [CoInductive] -> Just CoInductive 407 [Inductive] -> Just Inductive 408 _ -> Nothing 409 410-- | Only return @[Co]ConName@ if no ambiguity. 411exactConName :: Foldable t => t Induction -> Maybe KindOfName 412exactConName = fmap conKindOfName . exactConInduction 413 414-- | A set of 'KindOfName', for the sake of 'elemKindsOfNames'. 415data KindsOfNames 416 = AllKindsOfNames 417 | SomeKindsOfNames (Set KindOfName) -- ^ Only these kinds. 418 | ExceptKindsOfNames (Set KindOfName) -- ^ All but these Kinds. 419 420elemKindsOfNames :: KindOfName -> KindsOfNames -> Bool 421elemKindsOfNames k = \case 422 AllKindsOfNames -> True 423 SomeKindsOfNames ks -> k `Set.member` ks 424 ExceptKindsOfNames ks -> k `Set.notMember` ks 425 426allKindsOfNames :: KindsOfNames 427allKindsOfNames = AllKindsOfNames 428 429someKindsOfNames :: [KindOfName] -> KindsOfNames 430someKindsOfNames = SomeKindsOfNames . Set.fromList 431 432exceptKindsOfNames :: [KindOfName] -> KindsOfNames 433exceptKindsOfNames = ExceptKindsOfNames . Set.fromList 434 435-- | Decorate something with 'KindOfName' 436 437data WithKind a = WithKind 438 { theKind :: KindOfName 439 , kindedThing :: a 440 } deriving (Data, Show, Eq, Ord, Functor, Foldable, Traversable) 441 442-- | Where does a name come from? 443-- 444-- This information is solely for reporting to the user, 445-- see 'Agda.Interaction.InteractionTop.whyInScope'. 446data WhyInScope 447 = Defined 448 -- ^ Defined in this module. 449 | Opened C.QName WhyInScope 450 -- ^ Imported from another module. 451 | Applied C.QName WhyInScope 452 -- ^ Imported by a module application. 453 deriving (Data, Show, Generic) 454 455-- | A decoration of 'Agda.Syntax.Abstract.Name.QName'. 456data AbstractName = AbsName 457 { anameName :: A.QName 458 -- ^ The resolved qualified name. 459 , anameKind :: KindOfName 460 -- ^ The kind (definition, constructor, record field etc.). 461 , anameLineage :: WhyInScope 462 -- ^ Explanation where this name came from. 463 , anameMetadata :: NameMetadata 464 -- ^ Additional information needed during scope checking. Currently used 465 -- for generalized data/record params. 466 } 467 deriving (Data, Show, Generic) 468 469data NameMetadata = NoMetadata 470 | GeneralizedVarsMetadata (Map A.QName A.Name) 471 deriving (Data, Show, Generic) 472 473-- | A decoration of abstract syntax module names. 474data AbstractModule = AbsModule 475 { amodName :: A.ModuleName 476 -- ^ The resolved module name. 477 , amodLineage :: WhyInScope 478 -- ^ Explanation where this name came from. 479 } 480 deriving (Data, Show, Generic) 481 482instance Eq AbstractName where 483 (==) = (==) `on` anameName 484 485instance Ord AbstractName where 486 compare = compare `on` anameName 487 488instance LensFixity AbstractName where 489 lensFixity = lensAnameName . lensFixity 490 491-- | Van Laarhoven lens on 'anameName'. 492lensAnameName :: Lens' A.QName AbstractName 493lensAnameName f am = f (anameName am) <&> \ m -> am { anameName = m } 494 495instance Eq AbstractModule where 496 (==) = (==) `on` amodName 497 498instance Ord AbstractModule where 499 compare = compare `on` amodName 500 501-- | Van Laarhoven lens on 'amodName'. 502lensAmodName :: Lens' A.ModuleName AbstractModule 503lensAmodName f am = f (amodName am) <&> \ m -> am { amodName = m } 504 505 506data ResolvedName 507 = -- | Local variable bound by λ, Π, module telescope, pattern, @let@. 508 VarName 509 { resolvedVar :: A.Name 510 , resolvedBindingSource :: BindingSource -- ^ What kind of binder? 511 } 512 513 | -- | Function, data/record type, postulate. 514 DefinedName Access AbstractName A.Suffix -- ^ 'anameKind' can be 'DefName', 'MacroName', 'QuotableName'. 515 516 | -- | Record field name. Needs to be distinguished to parse copatterns. 517 FieldName (List1 AbstractName) -- ^ @('FldName' ==) . 'anameKind'@ for all names. 518 519 | -- | Data or record constructor name. 520 ConstructorName (Set Induction) (List1 AbstractName) -- ^ @isJust . 'isConName' . 'anameKind'@ for all names. 521 522 | -- | Name of pattern synonym. 523 PatternSynResName (List1 AbstractName) -- ^ @('PatternSynName' ==) . 'anameKind'@ for all names. 524 525 | -- | Unbound name. 526 UnknownName 527 deriving (Data, Show, Eq, Generic) 528 529instance Pretty ResolvedName where 530 pretty = \case 531 VarName x b -> pretty b <+> "variable" <+> pretty x 532 DefinedName a x s -> pretty a <+> (pretty x <> pretty s) 533 FieldName xs -> "field" <+> pretty xs 534 ConstructorName _ xs -> "constructor" <+> pretty xs 535 PatternSynResName x -> "pattern" <+> pretty x 536 UnknownName -> "<unknown name>" 537 538instance Pretty A.Suffix where 539 pretty NoSuffix = mempty 540 pretty (Suffix i) = text (show i) 541 542-- * Operations on name and module maps. 543 544mergeNames :: Eq a => ThingsInScope a -> ThingsInScope a -> ThingsInScope a 545mergeNames = Map.unionWith List.union 546 547mergeNamesMany :: Eq a => [ThingsInScope a] -> ThingsInScope a 548mergeNamesMany = Map.unionsWith List.union 549 550------------------------------------------------------------------------ 551-- * Operations on name spaces 552------------------------------------------------------------------------ 553 554-- | The empty name space. 555emptyNameSpace :: NameSpace 556emptyNameSpace = NameSpace Map.empty Map.empty Set.empty 557 558 559-- | Map functions over the names and modules in a name space. 560mapNameSpace :: (NamesInScope -> NamesInScope ) -> 561 (ModulesInScope -> ModulesInScope) -> 562 (InScopeSet -> InScopeSet ) -> 563 NameSpace -> NameSpace 564mapNameSpace fd fm fs ns = 565 ns { nsNames = fd $ nsNames ns 566 , nsModules = fm $ nsModules ns 567 , nsInScope = fs $ nsInScope ns 568 } 569 570-- | Zip together two name spaces. 571zipNameSpace :: (NamesInScope -> NamesInScope -> NamesInScope ) -> 572 (ModulesInScope -> ModulesInScope -> ModulesInScope) -> 573 (InScopeSet -> InScopeSet -> InScopeSet ) -> 574 NameSpace -> NameSpace -> NameSpace 575zipNameSpace fd fm fs ns1 ns2 = 576 ns1 { nsNames = nsNames ns1 `fd` nsNames ns2 577 , nsModules = nsModules ns1 `fm` nsModules ns2 578 , nsInScope = nsInScope ns1 `fs` nsInScope ns2 579 } 580 581-- | Map monadic function over a namespace. 582mapNameSpaceM :: Applicative m => 583 (NamesInScope -> m NamesInScope ) -> 584 (ModulesInScope -> m ModulesInScope) -> 585 (InScopeSet -> m InScopeSet ) -> 586 NameSpace -> m NameSpace 587mapNameSpaceM fd fm fs ns = update ns <$> fd (nsNames ns) <*> fm (nsModules ns) <*> fs (nsInScope ns) 588 where 589 update ns ds ms is = ns { nsNames = ds, nsModules = ms, nsInScope = is } 590 591------------------------------------------------------------------------ 592-- * General operations on scopes 593------------------------------------------------------------------------ 594 595instance Null Scope where 596 empty = emptyScope 597 null = __IMPOSSIBLE__ 598 -- TODO: define when needed, careful about scopeNameSpaces! 599 600instance Null ScopeInfo where 601 empty = emptyScopeInfo 602 null = __IMPOSSIBLE__ 603 -- TODO: define when needed, careful about _scopeModules! 604 605-- | The empty scope. 606emptyScope :: Scope 607emptyScope = Scope 608 { scopeName = noModuleName 609 , scopeParents = [] 610 , scopeNameSpaces = [ (nsid, emptyNameSpace) | nsid <- allNameSpaces ] 611 -- Note (Andreas, 2019-08-19): Cannot have [] here because 612 -- zipScope assumes all NameSpaces to be present and in the same order. 613 , scopeImports = Map.empty 614 , scopeDatatypeModule = Nothing 615 } 616 617-- | The empty scope info. 618emptyScopeInfo :: ScopeInfo 619emptyScopeInfo = ScopeInfo 620 { _scopeCurrent = noModuleName 621 , _scopeModules = Map.singleton noModuleName emptyScope 622 , _scopeVarsToBind = [] 623 , _scopeLocals = [] 624 , _scopePrecedence = [] 625 , _scopeInverseName = Map.empty 626 , _scopeInverseModule = Map.empty 627 , _scopeInScope = Set.empty 628 , _scopeFixities = Map.empty 629 , _scopePolarities = Map.empty 630 } 631 632-- | Map functions over the names and modules in a scope. 633mapScope :: (NameSpaceId -> NamesInScope -> NamesInScope ) -> 634 (NameSpaceId -> ModulesInScope -> ModulesInScope) -> 635 (NameSpaceId -> InScopeSet -> InScopeSet ) -> 636 Scope -> Scope 637mapScope fd fm fs = updateScopeNameSpaces $ AssocList.mapWithKey mapNS 638 where 639 mapNS acc = mapNameSpace (fd acc) (fm acc) (fs acc) 640 641-- | Same as 'mapScope' but applies the same function to all name spaces. 642mapScope_ :: (NamesInScope -> NamesInScope ) -> 643 (ModulesInScope -> ModulesInScope) -> 644 (InScopeSet -> InScopeSet ) -> 645 Scope -> Scope 646mapScope_ fd fm fs = mapScope (const fd) (const fm) (const fs) 647 648-- | Same as 'mapScope' but applies the function only on the given name space. 649mapScopeNS :: NameSpaceId 650 -> (NamesInScope -> NamesInScope ) 651 -> (ModulesInScope -> ModulesInScope) 652 -> (InScopeSet -> InScopeSet ) 653 -> Scope -> Scope 654mapScopeNS nsid fd fm fs = modifyNameSpace nsid $ mapNameSpace fd fm fs 655 656-- | Map monadic functions over the names and modules in a scope. 657mapScopeM :: Applicative m => 658 (NameSpaceId -> NamesInScope -> m NamesInScope ) -> 659 (NameSpaceId -> ModulesInScope -> m ModulesInScope) -> 660 (NameSpaceId -> InScopeSet -> m InScopeSet ) -> 661 Scope -> m Scope 662mapScopeM fd fm fs = updateScopeNameSpacesM $ AssocList.mapWithKeyM mapNS 663 where 664 mapNS acc = mapNameSpaceM (fd acc) (fm acc) (fs acc) 665 666-- | Same as 'mapScopeM' but applies the same function to both the public and 667-- private name spaces. 668mapScopeM_ :: Applicative m => 669 (NamesInScope -> m NamesInScope ) -> 670 (ModulesInScope -> m ModulesInScope) -> 671 (InScopeSet -> m InScopeSet ) -> 672 Scope -> m Scope 673mapScopeM_ fd fm fs = mapScopeM (const fd) (const fm) (const fs) 674 675-- | Zip together two scopes. The resulting scope has the same name as the 676-- first scope. 677zipScope :: (NameSpaceId -> NamesInScope -> NamesInScope -> NamesInScope ) -> 678 (NameSpaceId -> ModulesInScope -> ModulesInScope -> ModulesInScope) -> 679 (NameSpaceId -> InScopeSet -> InScopeSet -> InScopeSet ) -> 680 Scope -> Scope -> Scope 681zipScope fd fm fs s1 s2 = 682 s1 { scopeNameSpaces = 683 [ (nsid, zipNS nsid ns1 ns2) 684 | ((nsid, ns1), (nsid', ns2)) <- 685 fromMaybe __IMPOSSIBLE__ $ 686 zipWith' (,) (scopeNameSpaces s1) (scopeNameSpaces s2) 687 , assert (nsid == nsid') 688 ] 689 , scopeImports = (Map.union `on` scopeImports) s1 s2 690 } 691 where 692 assert True = True 693 assert False = __IMPOSSIBLE__ 694 zipNS acc = zipNameSpace (fd acc) (fm acc) (fs acc) 695 696-- | Same as 'zipScope' but applies the same function to both the public and 697-- private name spaces. 698zipScope_ :: (NamesInScope -> NamesInScope -> NamesInScope ) -> 699 (ModulesInScope -> ModulesInScope -> ModulesInScope) -> 700 (InScopeSet -> InScopeSet -> InScopeSet ) -> 701 Scope -> Scope -> Scope 702zipScope_ fd fm fs = zipScope (const fd) (const fm) (const fs) 703 704-- | Recompute the inScope sets of a scope. 705recomputeInScopeSets :: Scope -> Scope 706recomputeInScopeSets = updateScopeNameSpaces (map $ second recomputeInScope) 707 where 708 recomputeInScope ns = ns { nsInScope = allANames $ nsNames ns } 709 allANames :: NamesInScope -> InScopeSet 710 allANames = Set.fromList . map anameName . concat . Map.elems 711 712-- | Filter a scope keeping only concrete names matching the predicates. 713-- The first predicate is applied to the names and the second to the modules. 714filterScope :: (C.Name -> Bool) -> (C.Name -> Bool) -> Scope -> Scope 715filterScope pd pm = recomputeInScopeSets . mapScope_ (Map.filterKeys pd) (Map.filterKeys pm) id 716 -- We don't have enough information in the in scope set to do an 717 -- incremental update here, so just recompute it from the name map. 718 719-- | Return all names in a scope. 720allNamesInScope :: InScope a => Scope -> ThingsInScope a 721allNamesInScope = mergeNamesMany . map (inNameSpace . snd) . scopeNameSpaces 722 723allNamesInScope' :: InScope a => Scope -> ThingsInScope (a, Access) 724allNamesInScope' s = 725 mergeNamesMany [ map (, nameSpaceAccess nsId) <$> inNameSpace ns 726 | (nsId, ns) <- scopeNameSpaces s ] 727 728-- | Returns the scope's non-private names. 729exportedNamesInScope :: InScope a => Scope -> ThingsInScope a 730exportedNamesInScope = namesInScope [PublicNS, ImportedNS] 731 732namesInScope :: InScope a => [NameSpaceId] -> Scope -> ThingsInScope a 733namesInScope ids s = 734 mergeNamesMany [ inNameSpace (scopeNameSpace nsid s) | nsid <- ids ] 735 736allThingsInScope :: Scope -> NameSpace 737allThingsInScope s = 738 NameSpace { nsNames = allNamesInScope s 739 , nsModules = allNamesInScope s 740 , nsInScope = Set.unions $ map (nsInScope . snd) $ scopeNameSpaces s 741 } 742 743thingsInScope :: [NameSpaceId] -> Scope -> NameSpace 744thingsInScope fs s = 745 NameSpace { nsNames = namesInScope fs s 746 , nsModules = namesInScope fs s 747 , nsInScope = Set.unions [ nsInScope $ scopeNameSpace nsid s | nsid <- fs ] 748 } 749 750-- | Merge two scopes. The result has the name of the first scope. 751mergeScope :: Scope -> Scope -> Scope 752mergeScope = zipScope_ mergeNames mergeNames Set.union 753 754-- | Merge a non-empty list of scopes. The result has the name of the first 755-- scope in the list. 756mergeScopes :: [Scope] -> Scope 757mergeScopes [] = __IMPOSSIBLE__ 758mergeScopes ss = foldr1 mergeScope ss 759 760-- * Specific operations on scopes 761 762-- | Move all names in a scope to the given name space (except never move from 763-- Imported to Public). 764setScopeAccess :: NameSpaceId -> Scope -> Scope 765setScopeAccess a s = (`updateScopeNameSpaces` s) $ AssocList.mapWithKey $ const . ns 766 where 767 zero = emptyNameSpace 768 one = allThingsInScope s 769 imp = thingsInScope [ImportedNS] s 770 noimp = thingsInScope [PublicNS, PrivateNS] s 771 772 ns b = case (a, b) of 773 (PublicNS, PublicNS) -> noimp 774 (PublicNS, ImportedNS) -> imp 775 _ | a == b -> one 776 | otherwise -> zero 777 778-- | Update a particular name space. 779setNameSpace :: NameSpaceId -> NameSpace -> Scope -> Scope 780setNameSpace nsid ns = modifyNameSpace nsid $ const ns 781 782-- | Modify a particular name space. 783modifyNameSpace :: NameSpaceId -> (NameSpace -> NameSpace) -> Scope -> Scope 784modifyNameSpace nsid f = updateScopeNameSpaces $ AssocList.updateAt nsid f 785 786-- | Add a name to a scope. 787addNameToScope :: NameSpaceId -> C.Name -> AbstractName -> Scope -> Scope 788addNameToScope nsid x y = 789 mapScopeNS nsid 790 (Map.insertWith (flip List.union) x [y]) -- bind name x ↦ y 791 id -- no change to modules 792 (Set.insert $ anameName y) -- y is in scope now 793 794-- | Remove a name from a scope. Caution: does not update the nsInScope set. 795-- This is only used by rebindName and in that case we add the name right 796-- back (but with a different kind). 797removeNameFromScope :: NameSpaceId -> C.Name -> Scope -> Scope 798removeNameFromScope nsid x = mapScopeNS nsid (Map.delete x) id id 799 800-- | Add a module to a scope. 801addModuleToScope :: NameSpaceId -> C.Name -> AbstractModule -> Scope -> Scope 802addModuleToScope nsid x m = mapScopeNS nsid id addM id 803 where addM = Map.insertWith (flip List.union) x [m] 804 805-- | When we get here we cannot have both @using@ and @hiding@. 806data UsingOrHiding 807 = UsingOnly [C.ImportedName] 808 | HidingOnly [C.ImportedName] 809 810usingOrHiding :: C.ImportDirective -> UsingOrHiding 811usingOrHiding i = 812 case (using i, hiding i) of 813 (UseEverything, ys) -> HidingOnly ys 814 (Using xs , []) -> UsingOnly xs 815 _ -> __IMPOSSIBLE__ 816 817-- | Apply an 'ImportDirective' to a scope: 818-- 819-- 1. rename keys (C.Name) according to @renaming@; 820-- 821-- 2. for untouched keys, either of 822-- 823-- a) remove keys according to @hiding@, or 824-- b) filter keys according to @using@. 825-- 826-- Both steps could be done in one pass, by first preparing key-filtering 827-- functions @C.Name -> Maybe C.Name@ for defined names and module names. 828-- However, the penalty of doing it in two passes should not be too high. 829-- (Doubling the run time.) 830applyImportDirective :: C.ImportDirective -> Scope -> Scope 831applyImportDirective dir = fst . applyImportDirective_ dir 832 833-- | Version of 'applyImportDirective' that also returns sets of name 834-- and module name clashes introduced by @renaming@ to identifiers 835-- that are already imported by @using@ or lack of @hiding@. 836applyImportDirective_ 837 :: C.ImportDirective 838 -> Scope 839 -> (Scope, (Set C.Name, Set C.Name)) -- ^ Merged scope, clashing names, clashing module names. 840applyImportDirective_ dir@(ImportDirective{ impRenaming }) s 841 | null dir = (s, (empty, empty)) 842 -- Since each run of applyImportDirective rebuilds the scope 843 -- with cost O(n log n) time, it makes sense to test for the identity. 844 | otherwise = (recomputeInScopeSets $ mergeScope sUse sRen, (nameClashes, moduleClashes)) 845 where 846 -- Names kept via using/hiding. 847 sUse :: Scope 848 sUse = useOrHide (usingOrHiding dir) s 849 850 -- Things kept (under a different name) via renaming. 851 sRen :: Scope 852 sRen = rename impRenaming s 853 854 -- Which names are considered to be defined by a module? 855 -- The ones actually defined there publicly ('publicNS') 856 -- and the ones imported publicly ('ImportedNS')? 857 exportedNSs = [PublicNS, ImportedNS] 858 859 -- Name clashes introduced by the @renaming@ clause. 860 nameClashes :: Set C.Name 861 nameClashes = Map.keysSet rNames `Set.intersection` Map.keysSet uNames 862 -- NB: `intersection` returns a subset of the first argument. 863 -- To get the correct error location, i.e., in the @renaming@ clause 864 -- rather than at the definition location, we neet to return 865 -- names from the @renaming@ clause. (Issue #4154.) 866 where 867 uNames, rNames :: NamesInScope 868 uNames = namesInScope exportedNSs sUse 869 rNames = namesInScope exportedNSs sRen 870 871 -- Module name clashes introduced by the @renaming@ clause. 872 873 -- Note: need to cut and paste because of 'InScope' dependent types trickery. 874 moduleClashes :: Set C.Name 875 moduleClashes = Map.keysSet uModules `Set.intersection` Map.keysSet rModules 876 where 877 uModules, rModules :: ModulesInScope 878 uModules = namesInScope exportedNSs sUse 879 rModules = namesInScope exportedNSs sRen 880 881 882 -- Restrict scope by directive. 883 useOrHide :: UsingOrHiding -> Scope -> Scope 884 useOrHide (UsingOnly xs) = filterNames Set.member xs 885 -- Filter scope, keeping only xs. 886 useOrHide (HidingOnly xs) = filterNames Set.notMember $ map renFrom impRenaming ++ xs 887 -- Filter out xs and the to be renamed names from scope. 888 889 -- Filter scope by (`rel` xs). 890 -- O(n * log (length xs)). 891 filterNames :: (C.Name -> Set C.Name -> Bool) -> [C.ImportedName] -> 892 Scope -> Scope 893 filterNames rel xs = filterScope (`rel` Set.fromList ds) (`rel` Set.fromList ms) 894 where 895 (ds, ms) = partitionEithers $ for xs $ \case 896 ImportedName x -> Left x 897 ImportedModule m -> Right m 898 899 -- Apply a renaming to a scope. 900 -- O(n * (log n + log (length rho))). 901 rename :: [C.Renaming] -> Scope -> Scope 902 rename rho = mapScope_ (updateFxs . 903 updateThingsInScope (AssocList.apply drho)) 904 (updateThingsInScope (AssocList.apply mrho)) 905 id 906 where 907 (drho, mrho) = partitionEithers $ for rho $ \case 908 Renaming (ImportedName x) (ImportedName y) _fx _ -> Left (x, y) 909 Renaming (ImportedModule x) (ImportedModule y) _fx _ -> Right (x, y) 910 _ -> __IMPOSSIBLE__ 911 912 fixities :: AssocList C.Name Fixity 913 fixities = (`mapMaybe` rho) $ \case 914 Renaming _ (ImportedName y) (Just fx) _ -> Just (y, fx) 915 _ -> Nothing 916 917 -- Update fixities of abstract names targeted by renamed imported identifies. 918 updateFxs :: NamesInScope -> NamesInScope 919 updateFxs m = foldl upd m fixities 920 where 921 -- Update fixity of all abstract names targeted by concrete name y. 922 upd m (y, fx) = Map.adjust (map $ set lensFixity fx) y m 923 924 updateThingsInScope 925 :: forall a. SetBindingSite a 926 => (C.Name -> Maybe C.Name) 927 -> ThingsInScope a -> ThingsInScope a 928 updateThingsInScope f = Map.fromList . mapMaybe upd . Map.toAscList 929 where 930 upd :: (C.Name, [a]) -> Maybe (C.Name, [a]) 931 upd (x, ys) = f x <&> \ x' -> (x', setBindingSite (getRange x') ys) 932 933-- | Rename the abstract names in a scope. 934renameCanonicalNames :: Map A.QName A.QName -> Map A.ModuleName A.ModuleName -> 935 Scope -> Scope 936renameCanonicalNames renD renM = mapScope_ renameD renameM (Set.map newName) 937 where 938 newName x = Map.findWithDefault x x renD 939 newMod x = Map.findWithDefault x x renM 940 941 renameD = Map.map $ map $ over lensAnameName newName 942 renameM = Map.map $ map $ over lensAmodName newMod 943 944-- | Remove private name space of a scope. 945-- 946-- Should be a right identity for 'exportedNamesInScope'. 947-- @exportedNamesInScope . restrictPrivate == exportedNamesInScope@. 948restrictPrivate :: Scope -> Scope 949restrictPrivate s = setNameSpace PrivateNS emptyNameSpace 950 $ s { scopeImports = Map.empty } 951 952-- | Remove private things from the given module from a scope. 953restrictLocalPrivate :: ModuleName -> Scope -> Scope 954restrictLocalPrivate m = 955 mapScopeNS PrivateNS 956 (Map.mapMaybe rName) 957 (Map.mapMaybe rMod) 958 (Set.filter (not . (`isInModule` m))) 959 where 960 rName as = filterMaybe (not . null) $ filter (not . (`isInModule` m) . anameName) as 961 rMod as = filterMaybe (not . null) $ filter (not . (`isLtChildModuleOf` m) . amodName) as 962 963-- | Filter privates out of a `ScopeInfo` 964withoutPrivates :: ScopeInfo -> ScopeInfo 965withoutPrivates scope = over scopeModules (fmap $ restrictLocalPrivate m) scope 966 where 967 m = scope ^. scopeCurrent 968 969-- | Disallow using generalized variables from the scope 970disallowGeneralizedVars :: Scope -> Scope 971disallowGeneralizedVars = mapScope_ ((fmap . map) disallow) id id 972 where 973 disallow a = a { anameKind = disallowGen (anameKind a) } 974 disallowGen GeneralizeName = DisallowedGeneralizeName 975 disallowGen k = k 976 977-- | Add an explanation to why things are in scope. 978inScopeBecause :: (WhyInScope -> WhyInScope) -> Scope -> Scope 979inScopeBecause f = mapScope_ mapName mapMod id 980 where 981 mapName = fmap . map $ \a -> a { anameLineage = f $ anameLineage a } 982 mapMod = fmap . map $ \a -> a { amodLineage = f $ amodLineage a } 983 984-- | Get the public parts of the public modules of a scope 985publicModules :: ScopeInfo -> Map A.ModuleName Scope 986publicModules scope = Map.filterWithKey (\ m _ -> reachable m) allMods 987 where 988 -- Get all modules in the ScopeInfo. 989 allMods = Map.map restrictPrivate $ scope ^. scopeModules 990 root = scope ^. scopeCurrent 991 992 modules s = map amodName $ concat $ Map.elems $ allNamesInScope s 993 994 chase m = m : concatMap chase ms 995 where ms = maybe __IMPOSSIBLE__ modules $ Map.lookup m allMods 996 997 reachable = (`elem` chase root) 998 999publicNames :: ScopeInfo -> Set AbstractName 1000publicNames scope = 1001 Set.fromList $ concat $ Map.elems $ 1002 exportedNamesInScope $ mergeScopes $ Map.elems $ publicModules scope 1003 1004everythingInScope :: ScopeInfo -> NameSpace 1005everythingInScope scope = allThingsInScope $ mergeScopes $ 1006 (s0 :) $ map look $ scopeParents s0 1007 where 1008 look m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules 1009 s0 = look $ scope ^. scopeCurrent 1010 1011everythingInScopeQualified :: ScopeInfo -> NameSpace 1012everythingInScopeQualified scope = 1013 allThingsInScope $ mergeScopes $ 1014 chase Set.empty scopes 1015 where 1016 s0 = look $ scope ^. scopeCurrent 1017 scopes = s0 : map look (scopeParents s0) 1018 look m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules 1019 lookP = restrictPrivate . look 1020 1021 -- We start with the current module and all its parents and look through 1022 -- all their imports and submodules. 1023 chase seen [] = [] 1024 chase seen (s : ss) 1025 | Set.member name seen = chase seen ss 1026 | otherwise = s : chase (Set.insert name seen) (imports ++ submods ++ ss) 1027 where 1028 -- #4166: only include things that are actually in scope here 1029 inscope x _ = isInScope x == InScope 1030 name = scopeName s 1031 imports = map lookP $ Map.elems $ scopeImports s 1032 submods = map (lookP . amodName) $ concat $ Map.elems $ Map.filterWithKey inscope $ allNamesInScope s 1033 1034-- | Compute a flattened scope. Only include unqualified names or names 1035-- qualified by modules in the first argument. 1036flattenScope :: [[C.Name]] -> ScopeInfo -> Map C.QName [AbstractName] 1037flattenScope ms scope = 1038 Map.unionWith (++) 1039 (build ms allNamesInScope root) 1040 imported 1041 where 1042 current = moduleScope $ scope ^. scopeCurrent 1043 root = mergeScopes $ current : map moduleScope (scopeParents current) 1044 1045 imported = Map.unionsWith (++) 1046 [ qual c (build ms' exportedNamesInScope $ moduleScope a) 1047 | (c, a) <- Map.toList $ scopeImports root 1048 , let -- get the suffixes of c in ms 1049 ms' = mapMaybe (List.stripPrefix $ List1.toList $ C.qnameParts c) ms 1050 , not $ null ms' ] 1051 qual c = Map.mapKeys (q c) 1052 where 1053 q (C.QName x) = C.Qual x 1054 q (C.Qual m x) = C.Qual m . q x 1055 1056 build :: [[C.Name]] -> (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Map C.QName [AbstractName] 1057 build ms getNames s = Map.unionsWith (++) $ 1058 Map.mapKeysMonotonic C.QName (getNames s) : 1059 [ Map.mapKeysMonotonic (\ y -> C.Qual x y) $ 1060 build ms' exportedNamesInScope $ moduleScope m 1061 | (x, mods) <- Map.toList (getNames s) 1062 , let ms' = [ tl | hd:tl <- ms, hd == x ] 1063 , not $ null ms' 1064 , AbsModule m _ <- mods ] 1065 1066 moduleScope :: A.ModuleName -> Scope 1067 moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules 1068 1069-- | Get all concrete names in scope. Includes bound variables. 1070concreteNamesInScope :: ScopeInfo -> Set C.QName 1071concreteNamesInScope scope = 1072 Set.unions [ build allNamesInScope root, imported, locals ] 1073 where 1074 current = moduleScope $ scope ^. scopeCurrent 1075 root = mergeScopes $ current : map moduleScope (scopeParents current) 1076 1077 locals = Set.fromList [ C.QName x | (x, _) <- scope ^. scopeLocals ] 1078 1079 imported = Set.unions 1080 [ qual c (build exportedNamesInScope $ moduleScope a) 1081 | (c, a) <- Map.toList $ scopeImports root ] 1082 qual c = Set.map (q c) 1083 where 1084 q (C.QName x) = C.Qual x 1085 q (C.Qual m x) = C.Qual m . q x 1086 1087 build :: (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Set C.QName 1088 build getNames s = Set.unions $ 1089 Set.fromList (map C.QName $ Map.keys (getNames s :: ThingsInScope AbstractName)) : 1090 [ Set.mapMonotonic (\ y -> C.Qual x y) $ 1091 build exportedNamesInScope $ moduleScope m 1092 | (x, mods) <- Map.toList (getNames s) 1093 , prettyShow x /= "_" 1094 , AbsModule m _ <- mods ] 1095 1096 moduleScope :: A.ModuleName -> Scope 1097 moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules 1098 1099-- | Look up a name in the scope 1100scopeLookup :: InScope a => C.QName -> ScopeInfo -> [a] 1101scopeLookup q scope = map fst $ scopeLookup' q scope 1102 1103scopeLookup' :: forall a. InScope a => C.QName -> ScopeInfo -> [(a, Access)] 1104scopeLookup' q scope = 1105 nubOn fst $ 1106 findName q root ++ maybeToList topImports ++ imports 1107 where 1108 1109 -- 1. Finding a name in the current scope and its parents. 1110 1111 moduleScope :: A.ModuleName -> Scope 1112 moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules 1113 1114 current :: Scope 1115 current = moduleScope $ scope ^. scopeCurrent 1116 1117 root :: Scope 1118 root = mergeScopes $ current : map moduleScope (scopeParents current) 1119 1120 -- Find a concrete, possibly qualified name in scope @s@. 1121 findName :: forall a. InScope a => C.QName -> Scope -> [(a, Access)] 1122 findName q0 s = case q0 of 1123 C.QName x -> lookupName x s 1124 C.Qual x q -> do 1125 let -- Get the modules named @x@ in scope @s@. 1126 mods :: [A.ModuleName] 1127 mods = amodName . fst <$> lookupName x s 1128 -- Get the definitions named @x@ in scope @s@ and interpret them as modules. 1129 -- Andreas, 2013-05-01: Issue 836 debates this feature: 1130 -- Qualified constructors are qualified by their datatype rather than a module 1131 defs :: [A.ModuleName] -- NB:: Defined but not used 1132 defs = qnameToMName . anameName . fst <$> lookupName x s 1133 -- Andreas, 2013-05-01: Issue 836 complains about the feature 1134 -- that constructors can also be qualified by their datatype 1135 -- and projections by their record type. This feature is off 1136 -- if we just consider the modules: 1137 m <- mods 1138 -- The feature is on if we consider also the data and record types: 1139 -- trace ("mods ++ defs = " ++ show (mods ++ defs)) $ do 1140 -- m <- nub $ mods ++ defs -- record types will appear both as a mod and a def 1141 -- Get the scope of module m, if any, and remove its private definitions. 1142 let ss = Map.lookup m $ scope ^. scopeModules 1143 ss' = restrictPrivate <$> ss 1144 -- trace ("ss = " ++ show ss ) $ do 1145 -- trace ("ss' = " ++ show ss') $ do 1146 s' <- maybeToList ss' 1147 findName q s' 1148 where 1149 lookupName :: forall a. InScope a => C.Name -> Scope -> [(a, Access)] 1150 lookupName x s = fromMaybe [] $ Map.lookup x $ allNamesInScope' s 1151 1152 -- 2. Finding a name in the top imports. 1153 1154 topImports :: Maybe (a, Access) 1155 topImports = case (inScopeTag :: InScopeTag a) of 1156 NameTag -> Nothing 1157 ModuleTag -> first (`AbsModule` Defined) <$> imported q 1158 1159 imported :: C.QName -> Maybe (A.ModuleName, Access) 1160 imported q = fmap (,PublicAccess) $ Map.lookup q $ scopeImports root 1161 1162 -- 3. Finding a name in the imports belonging to an initial part of the qualifier. 1163 1164 imports :: [(a, Access)] 1165 imports = do 1166 (m, x) <- splitName q 1167 m <- maybeToList $ fst <$> imported m 1168 findName x $ restrictPrivate $ moduleScope m 1169 1170 -- return all possible splittings, e.g. 1171 -- splitName X.Y.Z = [(X, Y.Z), (X.Y, Z)] 1172 splitName :: C.QName -> [(C.QName, C.QName)] 1173 splitName (C.QName x) = [] 1174 splitName (C.Qual x q) = 1175 (C.QName x, q) : [ (C.Qual x m, r) | (m, r) <- splitName q ] 1176 1177 1178-- * Inverse look-up 1179 1180data AllowAmbiguousNames 1181 = AmbiguousAnything 1182 -- ^ Used for instance arguments to check whether a name is in scope, 1183 -- but we do not care whether is is ambiguous 1184 | AmbiguousConProjs 1185 -- ^ Ambiguous constructors, projections, or pattern synonyms. 1186 | AmbiguousNothing 1187 deriving (Eq) 1188 1189isNameInScope :: A.QName -> ScopeInfo -> Bool 1190isNameInScope q scope = 1191 billToPure [ Scoping, InverseScopeLookup ] $ 1192 Set.member q (scope ^. scopeInScope) 1193 1194isNameInScopeUnqualified :: A.QName -> ScopeInfo -> Bool 1195isNameInScopeUnqualified q scope = 1196 case inverseScopeLookupName' AmbiguousNothing q scope of 1197 C.QName{} : _ -> True -- NOTE: inverseScopeLookupName' puts unqualified names first 1198 _ -> False 1199 1200-- | Find the concrete names that map (uniquely) to a given abstract qualified name. 1201-- Sort by number of modules in the qualified name, unqualified names first. 1202inverseScopeLookupName :: A.QName -> ScopeInfo -> [C.QName] 1203inverseScopeLookupName = inverseScopeLookupName' AmbiguousConProjs 1204 1205inverseScopeLookupName' :: AllowAmbiguousNames -> A.QName -> ScopeInfo -> [C.QName] 1206inverseScopeLookupName' amb q scope = 1207 maybe [] (List1.toList . qnameConcrete) $ inverseScopeLookupName'' amb q scope 1208 1209-- | A version of 'inverseScopeLookupName' that also delivers the 'KindOfName'. 1210-- Used in highlighting. 1211inverseScopeLookupName'' :: AllowAmbiguousNames -> A.QName -> ScopeInfo -> Maybe NameMapEntry 1212inverseScopeLookupName'' amb q scope = billToPure [ Scoping , InverseScopeLookup ] $ do 1213 NameMapEntry k xs <- Map.lookup q (scope ^. scopeInverseName) 1214 NameMapEntry k <$> do List1.nonEmpty $ best $ List1.filter unambiguousName xs 1215 where 1216 best :: [C.QName] -> [C.QName] 1217 best = List.sortOn $ length . C.qnameParts 1218 1219 unique :: forall a . [a] -> Bool 1220 unique [] = __IMPOSSIBLE__ 1221 unique [_] = True 1222 unique (_:_:_) = False 1223 1224 unambiguousName :: C.QName -> Bool 1225 unambiguousName q = or 1226 [ amb == AmbiguousAnything 1227 , unique xs 1228 , amb == AmbiguousConProjs && or 1229 [ all (isJust . isConName) (k:ks) 1230 , k `elem` [ FldName, PatternSynName ] && all (k ==) ks 1231 ] 1232 ] 1233 where 1234 xs = scopeLookup q scope 1235 k:ks = map anameKind xs 1236 1237-- | Find the concrete names that map (uniquely) to a given abstract module name. 1238-- Sort by length, shortest first. 1239inverseScopeLookupModule :: A.ModuleName -> ScopeInfo -> [C.QName] 1240inverseScopeLookupModule = inverseScopeLookupModule' AmbiguousNothing 1241 1242inverseScopeLookupModule' :: AllowAmbiguousNames -> A.ModuleName -> ScopeInfo -> [C.QName] 1243inverseScopeLookupModule' amb m scope = billToPure [ Scoping , InverseScopeLookup ] $ 1244 best $ filter unambiguousModule $ findModule m 1245 where 1246 findModule m = fromMaybe [] $ Map.lookup m (scope ^. scopeInverseModule) 1247 1248 best :: [C.QName] -> [C.QName] 1249 best = List.sortOn $ length . C.qnameParts 1250 1251 unique :: forall a . [a] -> Bool 1252 unique [] = __IMPOSSIBLE__ 1253 unique [_] = True 1254 unique (_:_:_) = False 1255 1256 unambiguousModule q = amb == AmbiguousAnything || unique (scopeLookup q scope :: [AbstractModule]) 1257 1258recomputeInverseScopeMaps :: ScopeInfo -> ScopeInfo 1259recomputeInverseScopeMaps scope = billToPure [ Scoping , InverseScopeLookup ] $ 1260 scope { _scopeInverseName = nameMap 1261 , _scopeInverseModule = Map.fromList [ (x, findModule x) | x <- Map.keys moduleMap ++ Map.keys importMap ] 1262 , _scopeInScope = nsInScope $ everythingInScopeQualified scope 1263 } 1264 where 1265 this = scope ^. scopeCurrent 1266 current = this : scopeParents (moduleScope this) 1267 scopes = [ (m, restrict m s) | (m, s) <- Map.toList (scope ^. scopeModules) ] 1268 1269 moduleScope :: A.ModuleName -> Scope 1270 moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules 1271 1272 restrict m s | m `elem` current = s 1273 | otherwise = restrictPrivate s 1274 1275 internalName :: C.QName -> Bool 1276 internalName C.QName{} = False 1277 internalName (C.Qual m n) = intern m || internalName n 1278 where 1279 -- Recognize fresh names created Parser.y 1280 intern (C.Name _ _ (C.Id ('.' : '#' : _) :| [])) = True 1281 intern _ = False 1282 1283 findName :: Ord a => Map a [(A.ModuleName, C.Name)] -> a -> [C.QName] 1284 findName table q = do 1285 (m, x) <- fromMaybe [] $ Map.lookup q table 1286 if m `elem` current 1287 then return (C.QName x) 1288 else do 1289 y <- findModule m 1290 let z = C.qualify y x 1291 guard $ not $ internalName z 1292 return z 1293 1294 findModule :: A.ModuleName -> [C.QName] 1295 findModule q = findName moduleMap q ++ 1296 fromMaybe [] (Map.lookup q importMap) 1297 1298 importMap = Map.fromListWith (++) $ do 1299 (m, s) <- scopes 1300 (x, y) <- Map.toList $ scopeImports s 1301 return (y, singleton x) 1302 1303 moduleMap = Map.fromListWith (++) $ do 1304 (m, s) <- scopes 1305 (x, ms) <- Map.toList (allNamesInScope s) 1306 q <- amodName <$> ms 1307 return (q, singleton (m, x)) 1308 1309 nameMap :: NameMap 1310 nameMap = Map.fromListWith (<>) $ do 1311 (m, s) <- scopes 1312 (x, ms) <- Map.toList (allNamesInScope s) 1313 (q, k) <- (anameName &&& anameKind) <$> ms 1314 let ret z = return (q, NameMapEntry k $ singleton z) 1315 if m `elem` current 1316 then ret $ C.QName x 1317 else do 1318 y <- findModule m 1319 let z = C.qualify y x 1320 guard $ not $ internalName z 1321 ret z 1322 1323------------------------------------------------------------------------ 1324-- * Update binding site 1325------------------------------------------------------------------------ 1326 1327-- | Set the 'nameBindingSite' in an abstract name. 1328class SetBindingSite a where 1329 setBindingSite :: Range -> a -> a 1330 1331 default setBindingSite 1332 :: (SetBindingSite b, Functor t, t b ~ a) 1333 => Range -> a -> a 1334 setBindingSite = fmap . setBindingSite 1335 1336instance SetBindingSite a => SetBindingSite [a] 1337 1338instance SetBindingSite A.Name where 1339 setBindingSite r x = x { nameBindingSite = r } 1340 1341instance SetBindingSite A.QName where 1342 setBindingSite r x = x { qnameName = setBindingSite r $ qnameName x } 1343 1344-- | Sets the binding site of all names in the path. 1345instance SetBindingSite A.ModuleName where 1346 setBindingSite r (MName x) = MName $ setBindingSite r x 1347 1348instance SetBindingSite AbstractName where 1349 setBindingSite r x = x { anameName = setBindingSite r $ anameName x } 1350 1351instance SetBindingSite AbstractModule where 1352 setBindingSite r x = x { amodName = setBindingSite r $ amodName x } 1353 1354 1355------------------------------------------------------------------------ 1356-- * (Debug) printing 1357------------------------------------------------------------------------ 1358 1359instance Pretty AbstractName where 1360 pretty = pretty . anameName 1361 1362instance Pretty AbstractModule where 1363 pretty = pretty . amodName 1364 1365instance Pretty NameSpaceId where 1366 pretty = text . \case 1367 PublicNS -> "public" 1368 PrivateNS -> "private" 1369 ImportedNS -> "imported" 1370 1371instance Pretty NameSpace where 1372 pretty = vcat . prettyNameSpace 1373 1374prettyNameSpace :: NameSpace -> [Doc] 1375prettyNameSpace (NameSpace names mods _) = 1376 blockOfLines "names" (map pr $ Map.toList names) ++ 1377 blockOfLines "modules" (map pr $ Map.toList mods) 1378 where 1379 pr :: (Pretty a, Pretty b) => (a,b) -> Doc 1380 pr (x, y) = pretty x <+> "-->" <+> pretty y 1381 1382instance Pretty Scope where 1383 pretty scope@Scope{ scopeName = name, scopeParents = parents, scopeImports = imps } = 1384 vcat $ concat 1385 [ [ "scope" <+> pretty name ] 1386 , scopeNameSpaces scope >>= \ (nsid, ns) -> do 1387 block (pretty nsid) $ prettyNameSpace ns 1388 , ifNull (Map.keys imps) [] {-else-} $ \ ks -> 1389 block "imports" [ prettyList ks ] 1390 ] 1391 where 1392 block :: Doc -> [Doc] -> [Doc] 1393 block hd = map (nest 2) . blockOfLines hd 1394 1395-- | Add first string only if list is non-empty. 1396blockOfLines :: Doc -> [Doc] -> [Doc] 1397blockOfLines _ [] = [] 1398blockOfLines hd ss = hd : map (nest 2) ss 1399 1400instance Pretty ScopeInfo where 1401 pretty (ScopeInfo this mods toBind locals ctx _ _ _ _ _) = vcat $ concat 1402 [ [ "ScopeInfo" 1403 , nest 2 $ "current =" <+> pretty this 1404 ] 1405 , [ nest 2 $ "toBind =" <+> pretty locals | not (null toBind) ] 1406 , [ nest 2 $ "locals =" <+> pretty locals | not (null locals) ] 1407 , [ nest 2 $ "context =" <+> pretty ctx 1408 , nest 2 $ "modules" 1409 ] 1410 , map (nest 4 . pretty) $ Map.elems mods 1411 ] 1412 1413------------------------------------------------------------------------ 1414-- * Boring instances 1415------------------------------------------------------------------------ 1416 1417instance KillRange ScopeInfo where 1418 killRange m = m 1419 1420instance HasRange AbstractName where 1421 getRange = getRange . anameName 1422 1423instance SetRange AbstractName where 1424 setRange r x = x { anameName = setRange r $ anameName x } 1425 1426instance NFData Scope 1427instance NFData DataOrRecordModule 1428instance NFData NameSpaceId 1429instance NFData ScopeInfo 1430instance NFData KindOfName 1431instance NFData NameMapEntry 1432instance NFData BindingSource 1433instance NFData LocalVar 1434instance NFData NameSpace 1435instance NFData NameOrModule 1436instance NFData WhyInScope 1437instance NFData AbstractName 1438instance NFData NameMetadata 1439instance NFData AbstractModule 1440instance NFData ResolvedName 1441