1-- | Extract highlighting syntax from abstract syntax. 2-- 3-- Implements one big fold over abstract syntax. 4 5-- {-# OPTIONS_GHC -fwarn-unused-imports #-} -- Data.Semigroup is redundant in later GHC versions 6{-# OPTIONS_GHC -fwarn-unused-binds #-} 7 8module Agda.Interaction.Highlighting.FromAbstract 9 ( runHighlighter 10 , NameKinds 11 ) where 12 13import Prelude hiding (null) 14 15import Control.Applicative 16import Control.Monad.Reader 17 18import qualified Data.Map as Map 19import Data.Maybe 20import Data.Semigroup ( Semigroup(..) ) -- for ghc 8.0 21import Data.Void ( Void ) 22 23import Agda.Interaction.Highlighting.Precise hiding ( singleton ) 24import qualified Agda.Interaction.Highlighting.Precise as H 25import Agda.Interaction.Highlighting.Range ( rToR ) -- Range is ambiguous 26 27import Agda.Syntax.Abstract ( IsProjP(..) ) 28import qualified Agda.Syntax.Abstract as A 29import Agda.Syntax.Common as Common 30import Agda.Syntax.Concrete ( FieldAssignment'(..) ) 31import qualified Agda.Syntax.Concrete.Name as C 32import Agda.Syntax.Info ( ModuleInfo(..) ) 33import Agda.Syntax.Literal 34import qualified Agda.Syntax.Position as P 35import Agda.Syntax.Position ( Range, HasRange, getRange, noRange ) 36import Agda.Syntax.Scope.Base ( AbstractName(..), ResolvedName(..), exactConName ) 37 38import Agda.TypeChecking.Monad 39 hiding (ModuleInfo, MetaInfo, Primitive, Constructor, Record, Function, Datatype) 40 41import Agda.Utils.FileName 42import Agda.Utils.Function 43import Agda.Utils.Functor 44import Agda.Utils.List ( initLast1 ) 45import Agda.Utils.List1 ( List1 ) 46import qualified Agda.Utils.List1 as List1 47import Agda.Utils.Maybe 48import qualified Agda.Utils.Maybe.Strict as Strict 49import Agda.Utils.Pretty 50import Agda.Utils.Singleton 51 52-- Entry point: 53-- | Create highlighting info for some piece of syntax. 54runHighlighter :: 55 Hilite a => 56 SourceToModule -> AbsolutePath -> NameKinds -> a -> 57 HighlightingInfoBuilder 58runHighlighter modMap fileName kinds x = 59 runReader (hilite x) $ 60 HiliteEnv 61 { hleNameKinds = kinds 62 , hleModMap = modMap 63 , hleFileName = fileName 64 } 65 66-- | Environment of the highlighter. 67data HiliteEnv = HiliteEnv 68 { hleNameKinds :: NameKinds 69 -- ^ Function mapping qualified names to their kind. 70 , hleModMap :: SourceToModule 71 -- ^ Maps source file paths to module names. 72 , hleFileName :: AbsolutePath 73 -- ^ The file name of the current module. Used for consistency checking. 74 } 75 76-- | A function mapping names to the kind of name they stand for. 77type NameKinds = A.QName -> Maybe NameKind 78 79-- | Highlighting monad. 80type HiliteM = Reader HiliteEnv 81 82-- | Highlighter. 83 84type Hiliter = HiliteM HighlightingInfoBuilder 85 86instance Monoid Hiliter where 87 mempty = pure mempty 88 mappend = (<>) 89 90-- | Traversal to extract highlighting information. 91 92class Hilite a where 93 hilite :: a -> Hiliter 94 95 default hilite :: (Foldable t, Hilite b, t b ~ a) => a -> Hiliter 96 hilite = foldMap hilite 97 98-- * Generic instances 99--------------------------------------------------------------------------- 100 101instance Hilite a => Hilite [a] 102instance Hilite a => Hilite (List1 a) 103instance Hilite a => Hilite (Maybe a) 104instance Hilite a => Hilite (WithHiding a) 105 106instance Hilite Void where 107 hilite _ = mempty 108 109instance (Hilite a, Hilite b) => Hilite (Either a b) where 110 hilite = either hilite hilite 111 112instance (Hilite a, Hilite b) => Hilite (a, b) where 113 hilite (a, b) = hilite a <> hilite b 114 115-- * Major syntactic categories 116--------------------------------------------------------------------------- 117 118-- | Reengineered from the old Geniplate-implemented highlighting extraction. 119-- This was the old procedure: 120-- 121-- Traversal over declaration in abstract syntax that collects the 122-- following hiliting information: 123-- 124-- [1. @constructorInfo@ (highest prio)] 125-- 2. @theRest@ (medium prio) 126-- 3. @nameInfo@ (lowest prio) 127-- 128-- @nameInfo@: 129-- "All names mentioned in the syntax tree (not bound variables)." 130-- For each possibly ambiguous name (QName and AmbiguousQName) 131-- that not isExtendedLambdaName, 132-- do @hiliteAmbiguous@ (used to be called@generate@). 133-- 134-- @constructorInfo@ (only when highlighting level == Full): 135-- "After the code has been type checked more information may be 136-- available for overloaded constructors, and 137-- generateConstructorInfo takes advantage of this information. 138-- Note, however, that highlighting for overloaded constructors is 139-- included also in nameInfo." 140-- This is not computed by recursion over the abstract syntax, 141-- but gets the constructor names stDisambiguatedNames 142-- that fall within the bounds of the current declaration. 143-- 144-- @theRest@: 145-- Bound variables, dotted patterns, record fields, module names, 146-- the "as" and "to" symbols and some other things. 147-- 148-- Here is a table what @theRest@ used to collect: 149-- 150-- --------------------------------------------------------------------- 151-- | A.Expr 152-- --------------------------------------------------------------------- 153-- | getVarAndField (Expr) | A.Var | bound 154-- | getVarAndField | A.Rec(Update) | field 155-- | getExpr (Expr) | A.PatternSyn | patsyn 156-- | getExpr | A.Macro | macro 157-- --------------------------------------------------------------------- 158-- | A.LetBinding 159-- --------------------------------------------------------------------- 160-- | getLet | A.LetBind | bound 161-- | getLet | A.LetDeclaredVariable | bound 162-- --------------------------------------------------------------------- 163-- | A.LamBinding 164-- --------------------------------------------------------------------- 165-- | getLam | A.Binder under A.DomainFree | bound 166-- | getTyped | A.Binder under A.TBind | bound 167-- --------------------------------------------------------------------- 168-- | A.Pattern' 169-- --------------------------------------------------------------------- 170-- | getPattern(Syn) | A.VarP | bound 171-- | getPattern(Syn) | A.AsP | bound 172-- | getPattern(Syn) | A.DotP (not isProjP) | DottedPattern 173-- | getPattern(Syn) | A.RecP | field 174-- | getPattern(Syn) | A.PatternSynP | patsyn 175-- --------------------------------------------------------------------- 176-- | A.Declaration 177-- --------------------------------------------------------------------- 178-- | getFieldDecl | A.Field under A.RecDef | field 179-- | getPatSynArgs | A.PatternSynDef | bound 180-- | getPragma | A.BuiltinPragma... | keyword 181-- --------------------------------------------------------------------- 182-- | A.NamedArg (polymorphism not supported in geniplate) 183-- --------------------------------------------------------------------- 184-- | getNamedArg | NamedArg a | nameOf 185-- | getNamedArgE | NamedArg Exp | nameOf 186-- | getNamedArgP | NamedArg Pattern | nameOf 187-- | getNamedArgB | NamedArg BindName | nameOf 188-- | getNamedArgL | NamedArg LHSCore | nameOf 189-- 190-- | getModuleName | A.MName | mod 191-- | getModuleInfo | ModuleInfo | asName, (range of as,to) 192-- | getQuantityAttr | Common.Quantity | Symbol (if range) 193 194instance Hilite A.RecordDirectives where 195 hilite (RecordDirectives _ _ _ c) = hilite c 196 197instance Hilite A.Declaration where 198 hilite = \case 199 A.Axiom _ax _di ai _occ x e -> hl ai <> hl x <> hl e 200 A.Generalize _names _di ai x e -> hl ai <> hl x <> hl e 201 A.Field _di x e -> hlField x <> hl e 202 A.Primitive _di x e -> hl x <> hl e 203 A.Mutual _mi ds -> hl ds 204 A.Section _r x tel ds -> hl x <> hl tel <> hl ds 205 A.Apply mi x a _ci dir -> hl mi <> hl x <> hl a <> hl dir 206 A.Import mi x dir -> hl mi <> hl x <> hl dir 207 A.Open mi x dir -> hl mi <> hl x <> hl dir 208 A.FunDef _di x _delayed cs -> hl x <> hl cs 209 A.DataSig _di x tel e -> hl x <> hl tel <> hl e 210 A.DataDef _di x _uc pars cs -> hl x <> hl pars <> hl cs 211 A.RecSig _di x tel e -> hl x <> hl tel <> hl e 212 A.RecDef _di x _uc dir bs e ds -> hl x <> hl dir <> hl bs <> hl e <> hl ds 213 A.PatternSynDef x xs p -> hl x <> hl xs <> hl p 214 A.UnquoteDecl _mi _di xs e -> hl xs <> hl e 215 A.UnquoteDef _di xs e -> hl xs <> hl e 216 A.ScopedDecl s ds -> hl ds 217 A.Pragma _r pragma -> hl pragma 218 where 219 hl a = hilite a 220 hlField x = hiliteField (concreteQualifier x) (concreteBase x) (Just $ bindingSite x) 221 222instance Hilite A.Pragma where 223 hilite = \case 224 A.OptionsPragma _strings -> mempty 225 A.BuiltinPragma b x -> singleAspect Keyword b <> hilite x 226 A.BuiltinNoDefPragma b k x -> singleAspect Keyword b <> hiliteQName (Just $ kindOfNameToNameKind k) x 227 A.CompilePragma b x _foreign -> singleAspect Keyword b <> hilite x 228 A.RewritePragma r xs -> singleAspect Keyword r <> hilite xs 229 A.StaticPragma x -> hilite x 230 A.EtaPragma x -> hilite x 231 A.InjectivePragma x -> hilite x 232 A.InlinePragma _inline x -> hilite x 233 A.DisplayPragma x ps e -> hilite x <> hilite ps <> hilite e 234 235instance Hilite A.Expr where 236 hilite = \case 237 A.Var x -> hl $ A.BindName x -- bound variable like binder 238 A.Def' q _ -> hiliteQName Nothing q 239 A.Proj _o qs -> hiliteAmbiguousQName Nothing qs -- Issue #4604: not: hiliteProjection qs 240 -- Names from @open R r@ should not be highlighted as projections 241 A.Con qs -> hiliteAmbiguousQName Nothing qs -- TODO? Con aspect 242 A.PatternSyn qs -> hilitePatternSynonym qs 243 A.Macro q -> hiliteQName (Just Macro) q 244 A.Lit _r l -> hl l 245 A.QuestionMark _mi _ii -> mempty 246 A.Underscore _mi -> mempty 247 A.Dot _r e -> hl e -- TODO? Projection? 248 A.App _r e es -> hl e <> hl es 249 A.WithApp _r e es -> hl e <> hl es 250 A.Lam _r bs e -> hl bs <> hl e 251 A.AbsurdLam _r _h -> mempty 252 A.ExtendedLam _r _di _e _q cs -> hl cs -- No hilighting of generated extended lambda name! 253 A.Pi _r tel b -> hl tel <> hl b 254 A.Generalized _qs e -> hl e 255 A.Fun _r a b -> hl a <> hl b 256 A.Let _r bs e -> hl bs <> hl e 257 A.ETel _tel -> mempty -- Printing only construct 258 A.Rec _r ass -> hl ass 259 A.RecUpdate _r e ass -> hl e <> hl ass 260 A.ScopedExpr _ e -> hl e 261 A.Quote _r -> mempty 262 A.QuoteTerm _r -> mempty 263 A.Unquote _r -> mempty 264 A.Tactic _r e es -> hl e <> hl es 265 A.DontCare e -> hl e 266 where 267 hl a = hilite a 268 269instance (Hilite a, IsProjP a) => Hilite (A.Pattern' a) where 270 hilite = \case 271 A.VarP x -> hl x 272 A.ConP _i qs es -> hiliteInductiveConstructor qs <> hl es 273 -- No matching on coinductive constructors, thus, can determine NameKind here. 274 A.ProjP _r _o qs -> hiliteProjection qs 275 A.DefP _r qs es -> hl qs <> hl es 276 A.WildP _r -> mempty 277 A.AsP _r x p -> hl x <> hl p 278 A.DotP r e -> case isProjP e of 279 Nothing -> singleOtherAspect DottedPattern r <> hl e 280 Just (_o, qs) -> hiliteProjection qs 281 A.AbsurdP _r -> mempty 282 A.LitP _r l -> hl l 283 A.PatternSynP _r qs es -> hilitePatternSynonym qs <> hl es 284 A.RecP _r ps -> hl ps 285 A.EqualP _r ps -> hl ps 286 A.WithP _ p -> hl p 287 A.AnnP _r a p -> hl p 288 289 where 290 hl a = hilite a 291 292instance Hilite Literal where 293 hilite = \case 294 LitNat{} -> mempty 295 LitWord64{} -> mempty 296 LitFloat{} -> mempty 297 LitString{} -> mempty 298 LitChar{} -> mempty 299 LitQName x -> hilite x 300 LitMeta _fileName _id -> mempty 301 302-- * Minor syntactic categories 303--------------------------------------------------------------------------- 304 305instance Hilite A.LHS where 306 hilite (A.LHS _r lhs) = hilite lhs 307 308instance (Hilite a, IsProjP a) => Hilite (A.LHSCore' a) where 309 hilite = \case 310 A.LHSHead q ps -> hilite q <> hilite ps 311 A.LHSProj q lhs ps -> hilite lhs <> hilite q <> hilite ps -- TODO? Projection? 312 A.LHSWith lhs wps ps -> hilite lhs <> hilite wps <> hilite ps 313 314instance Hilite A.RHS where 315 hilite = \case 316 A.RHS e _ce -> hl e 317 A.AbsurdRHS -> mempty 318 A.WithRHS _q es cs -> hl es <> hl cs -- No highlighting for with-function-name! 319 A.RewriteRHS eqs strippedPats rhs wh -> hl eqs <> hl strippedPats <> hl rhs <> hl wh 320 where 321 hl a = hilite a 322 323instance (HasRange n, Hilite p, Hilite e) => Hilite (RewriteEqn' x n p e) where 324 hilite = \case 325 Rewrite es -> hilite $ fmap snd es 326 Invert _x pes -> hilite pes 327 328instance Hilite a => Hilite (A.Clause' a) where 329 hilite (A.Clause lhs strippedPats rhs wh _catchall) = 330 hilite lhs <> hilite strippedPats <> hilite rhs <> hilite wh 331 332instance Hilite A.ProblemEq where 333 hilite (A.ProblemEq p _t _dom) = hilite p 334 335instance Hilite A.WhereDeclarations where 336 hilite (A.WhereDecls m ds) = hilite m <> hilite ds 337 338instance Hilite A.GeneralizeTelescope where 339 hilite (A.GeneralizeTel _gen tel) = hilite tel 340 341instance Hilite A.DataDefParams where 342 hilite (A.DataDefParams _gen pars) = hilite pars 343 344instance Hilite A.ModuleApplication where 345 hilite = \case 346 A.SectionApp tel x es -> hilite tel <> hilite x <> hilite es 347 A.RecordModuleInstance x -> hilite x 348 349instance Hilite A.LetBinding where 350 hilite = \case 351 A.LetBind _r ai x t e -> hl ai <> hl x <> hl t <> hl e 352 A.LetPatBind _r p e -> hl p <> hl e 353 A.LetApply mi x es _ci dir -> hl mi <> hl x <> hl es <> hl dir 354 A.LetOpen mi x dir -> hl mi <> hl x <> hl dir 355 A.LetDeclaredVariable x -> hl x 356 where 357 hl x = hilite x 358 359instance Hilite A.TypedBinding where 360 hilite = \case 361 A.TBind _r tac binds e -> hilite tac <> hilite binds <> hilite e 362 A.TLet _r binds -> hilite binds 363 364instance Hilite A.LamBinding where 365 hilite = \case 366 A.DomainFree tac binds -> hilite tac <> hilite binds 367 A.DomainFull bind -> hilite bind 368 369instance Hilite a => Hilite (A.Binder' a) where 370 hilite (A.Binder p x) = hilite p <> hilite x 371 372instance Hilite A.BindName where 373 hilite (A.BindName x) = hiliteBound x 374 375instance Hilite a => Hilite (FieldAssignment' a) where 376 hilite (FieldAssignment x e) = hiliteField [] x Nothing <> hilite e 377 378instance (Hilite a, HasRange n) => Hilite (Named n a) where 379 hilite (Named mn e) 380 = maybe mempty (singleAspect $ Name (Just Argument) False) mn 381 <> hilite e 382 383instance Hilite a => Hilite (Arg a) where 384 hilite (Arg ai e) = hilite ai <> hilite e 385 386instance Hilite ArgInfo where 387 hilite (ArgInfo _hiding modality _origin _fv _a) = hilite modality 388 389instance Hilite Modality where 390 hilite (Modality _relevance quantity _cohesion) = hilite quantity 391 392-- | If the 'Quantity' attribute comes with a 'Range', highlight the 393-- corresponding attribute as 'Symbol'. 394instance Hilite Quantity where 395 hilite = singleAspect Symbol 396 397instance Hilite ModuleInfo where 398 hilite (ModuleInfo _r rAsTo asName _open _impDir) 399 = singleAspect Symbol rAsTo -- TODO: 'to' already covered by A.ImportDirective 400 <> maybe mempty hiliteAsName asName 401 -- <> hilite impDir -- Should be covered by A.ImportDirective 402 where 403 hiliteAsName :: C.Name -> Hiliter 404 hiliteAsName n = hiliteCName [] n noRange Nothing $ nameAsp Module 405 406instance (Hilite m, Hilite n, Hilite (RenamingTo m), Hilite (RenamingTo n)) 407 => Hilite (ImportDirective' m n) where 408 hilite (ImportDirective _r using hiding renaming _ropen) = 409 hilite using <> hilite hiding <> hilite renaming 410 411instance (Hilite m, Hilite n) => Hilite (Using' m n) where 412 hilite = \case 413 UseEverything -> mempty 414 Using using -> hilite using 415 416instance (Hilite m, Hilite n, Hilite (RenamingTo m), Hilite (RenamingTo n)) 417 => Hilite (Renaming' m n) where 418 hilite (Renaming from to _fixity rangeKwTo) 419 = hilite from 420 <> singleAspect Symbol rangeKwTo 421 -- Currently, the "to" is already highlited by rAsTo above. 422 -- TODO: remove the "to" ranges from rAsTo. 423 <> hilite (RenamingTo to) 424 425instance (Hilite m, Hilite n) => Hilite (ImportedName' m n) where 426 hilite = \case 427 ImportedModule m -> hilite m 428 ImportedName n -> hilite n 429 430-- * Highlighting of names 431--------------------------------------------------------------------------- 432 433instance Hilite DisambiguatedName where 434 hilite (DisambiguatedName k x) = hiliteQName (Just k) x 435 436instance Hilite ResolvedName where 437 hilite = \case 438 VarName x _bindSrc -> hiliteBound x 439 DefinedName _acc x _suffix -> hilite $ anameName x 440 FieldName xs -> hiliteProjection $ A.AmbQ $ fmap anameName xs 441 ConstructorName i xs -> hiliteAmbiguousQName k $ A.AmbQ $ fmap anameName xs 442 where k = kindOfNameToNameKind <$> exactConName i 443 PatternSynResName xs -> hilitePatternSynonym $ A.AmbQ $ fmap anameName xs 444 UnknownName -> mempty 445 446instance Hilite A.QName where 447 hilite = hiliteQName Nothing 448 449instance Hilite A.AmbiguousQName where 450 hilite = hiliteAmbiguousQName Nothing 451 452instance Hilite A.ModuleName where 453 hilite m@(A.MName xs) = do 454 modMap <- asks hleModMap 455 hiliteModule (isTopLevelModule modMap, m) 456 where 457 isTopLevelModule modMap = 458 case mapMaybe 459 ((Strict.toLazy . P.srcFile) <=< (P.rStart . A.nameBindingSite)) xs of 460 f : _ -> 461 Map.lookup f modMap 462 == Just (C.toTopLevelModuleName $ A.mnameToConcrete m) 463 [] -> False 464 465 -- Andreas, 2020-09-29, issue #4952. 466-- The target of a @renaming@ clause needs to be highlighted in a special way. 467newtype RenamingTo a = RenamingTo a 468 469instance Hilite (RenamingTo A.QName) where 470 -- Andreas, 2020-09-29, issue #4952. 471 -- Do not include the bindingSite, because the HTML backed turns it into garbage. 472 hilite (RenamingTo q) = do 473 kind <- asks hleNameKinds <&> ($ q) 474 hiliteAName q False $ nameAsp' kind 475 476instance Hilite (RenamingTo A.ModuleName) where 477 -- Andreas, 2020-09-29, issue #4952. 478 -- Do not include the bindingSite, because the HTML backed turns it into garbage. 479 hilite (RenamingTo (A.MName ns)) = flip foldMap ns $ \ n -> 480 hiliteCName [] (A.nameConcrete n) noRange Nothing $ nameAsp Module 481 482instance (Hilite (RenamingTo m), Hilite (RenamingTo n)) 483 => Hilite (RenamingTo (ImportedName' m n)) where 484 hilite (RenamingTo x) = case x of 485 ImportedModule m -> hilite (RenamingTo m) 486 ImportedName n -> hilite (RenamingTo n) 487 488hiliteQName 489 :: Maybe NameKind -- ^ Is 'NameKind' already known from the context? 490 -> A.QName 491 -> Hiliter 492hiliteQName mkind q 493 | isExtendedLambdaName q = mempty 494 | isAbsurdLambdaName q = mempty 495 | otherwise = do 496 kind <- ifJust mkind (pure . Just) {-else-} $ asks hleNameKinds <&> ($ q) 497 hiliteAName q True $ nameAsp' kind 498 499-- | Takes the first 'NameKind'. Binding site only included if unique. 500hiliteAmbiguousQName 501 :: Maybe NameKind -- ^ Is 'NameKind' already known from the context? 502 -> A.AmbiguousQName 503 -> Hiliter 504hiliteAmbiguousQName mkind (A.AmbQ qs) = do 505 kind <- ifJust mkind (pure . Just) {-else-} $ do 506 kinds <- asks hleNameKinds 507 pure $ listToMaybe $ List1.catMaybes $ fmap kinds qs 508 -- Ulf, 2014-06-03: [issue1064] It's better to pick the first rather 509 -- than doing no highlighting if there's an ambiguity between an 510 -- inductive and coinductive constructor. 511 flip foldMap qs $ \ q -> 512 hiliteAName q include $ nameAsp' kind 513 where 514 include = List1.allEqual $ fmap bindingSite qs 515 516hiliteBound :: A.Name -> Hiliter 517hiliteBound x = 518 hiliteCName [] (A.nameConcrete x) noRange (Just $ A.nameBindingSite x) $ nameAsp Bound 519 520hiliteInductiveConstructor :: A.AmbiguousQName -> Hiliter 521hiliteInductiveConstructor = hiliteAmbiguousQName $ Just $ Constructor Inductive 522 523hilitePatternSynonym :: A.AmbiguousQName -> Hiliter 524hilitePatternSynonym = hiliteInductiveConstructor -- There are no coinductive pattern synonyms!? 525 526hiliteProjection :: A.AmbiguousQName -> Hiliter 527hiliteProjection = hiliteAmbiguousQName (Just Field) 528 529hiliteField :: [C.Name] -> C.Name -> Maybe Range -> Hiliter 530hiliteField xs x bindingR = hiliteCName xs x noRange bindingR $ nameAsp Field 531 532-- For top level modules, we set the binding site to the beginning of the file 533-- so that clicking on an imported module will jump to the beginning of the file 534-- which defines this module. 535hiliteModule :: (Bool, A.ModuleName) -> Hiliter 536hiliteModule (isTopLevelModule, A.MName []) = mempty 537hiliteModule (isTopLevelModule, A.MName (n:ns)) = 538 hiliteCName 539 (map A.nameConcrete ms) 540 (A.nameConcrete m) 541 noRange 542 mR 543 (nameAsp Module) 544 where 545 (ms, m) = initLast1 n ns 546 mR = Just $ 547 applyWhen isTopLevelModule P.beginningOfFile $ 548 A.nameBindingSite m 549 550-- This was Highlighting.Generate.nameToFile: 551-- | Converts names to suitable 'File's. 552hiliteCName 553 :: [C.Name] 554 -- ^ The name qualifier (may be empty). 555 -> C.Name -- ^ The base name. 556 -> Range 557 -- ^ The 'Range' of the name in its fixity declaration (if any). 558 -> Maybe Range 559 -- ^ The definition site of the name. The calculated 560 -- meta information is extended with this information, if possible. 561 -> (Bool -> Aspects) 562 -- ^ Meta information to be associated with the name. 563 -- The argument is 'True' iff the name is an operator. 564 -> Hiliter 565hiliteCName xs x fr mR asp = do 566 HiliteEnv _ modMap fileName <- ask 567 -- We don't care if we get any funny ranges. 568 if all (== Strict.Just fileName) fileNames then pure $ 569 frFile modMap <> 570 H.singleton (rToR rs) 571 (aspects { definitionSite = mFilePos modMap }) 572 else 573 mempty 574 where 575 aspects = asp $ C.isOperator x 576 fileNames = mapMaybe (fmap P.srcFile . P.rStart . getRange) (x : xs) 577 frFile modMap = H.singleton (rToR fr) (aspects { definitionSite = notHere <$> mFilePos modMap }) 578 rs = getRange (x : xs) 579 580 -- The fixity declaration should not get a symbolic anchor. 581 notHere d = d { defSiteHere = False } 582 583 mFilePos 584 :: SourceToModule -- Maps source file paths to module names. 585 -> Maybe DefinitionSite 586 mFilePos modMap = do 587 r <- mR 588 P.Pn { P.srcFile = Strict.Just f, P.posPos = p } <- P.rStart r 589 mod <- Map.lookup f modMap 590 -- Andreas, 2017-06-16, Issue #2604: Symbolic anchors. 591 -- We drop the file name part from the qualifiers, since 592 -- this is contained in the html file name already. 593 -- We want to get anchors of the form: 594 -- @<a name="TopLevelModule.html#LocalModule.NestedModule.identifier">@ 595 let qualifiers = drop (length $ C.moduleNameParts mod) xs 596 -- For bound variables, we do not create symbolic anchors. 597 local = maybe True isLocalAspect $ aspect aspects 598 return $ DefinitionSite 599 { defSiteModule = mod 600 , defSitePos = fromIntegral p 601 -- Is our current position the definition site? 602 , defSiteHere = r == getRange x 603 -- For bound variables etc. we do not create a symbolic anchor name. 604 -- Also not for names that include anonymous modules, 605 -- otherwise, we do not get unique anchors. 606 , defSiteAnchor = if local || C.isNoName x || any Common.isUnderscore qualifiers 607 then Nothing 608 else Just $ prettyShow $ foldr C.Qual (C.QName x) qualifiers 609 } 610 611 -- Is the name a bound variable or similar? If in doubt, yes. 612 isLocalAspect :: Aspect -> Bool 613 isLocalAspect = \case 614 Name (Just kind) _ -> isLocal kind 615 _ -> True 616 isLocal :: NameKind -> Bool 617 isLocal = \case 618 Bound -> True 619 Generalizable -> True 620 Argument -> True 621 Constructor{} -> False 622 Datatype -> False 623 Field -> False 624 Function -> False 625 Module -> False 626 Postulate -> False 627 Primitive -> False 628 Record -> False 629 Macro -> False 630 631-- This was Highlighting.Generate.nameToFileA: 632-- | A variant of 'hiliteCName' for qualified abstract names. 633hiliteAName 634 :: A.QName 635 -- ^ The name. 636 -> Bool 637 -- ^ Should the binding site be included in the file? 638 -> (Bool -> Aspects) 639 -- ^ Meta information to be associated with the name. 640 -- ^ The argument is 'True' iff the name is an operator. 641 -> Hiliter 642hiliteAName x include asp = do 643 fileName <- asks hleFileName 644 hiliteCName (concreteQualifier x) 645 (concreteBase x) 646 (rangeOfFixityDeclaration fileName) 647 (if include then Just $ bindingSite x else Nothing) 648 asp 649 <> (notationFile fileName) 650 where 651 -- TODO: Currently we highlight fixity and syntax declarations by 652 -- producing highlighting something like once per occurrence of the 653 -- related name(s) in the file of the declaration (and we explicitly 654 -- avoid doing this for other files). Perhaps it would be better to 655 -- only produce this highlighting once. 656 657 rangeOfFixityDeclaration fileName = 658 if P.rangeFile r == Strict.Just fileName 659 then r else noRange 660 where 661 r = theNameRange $ A.nameFixity $ A.qnameName x 662 663 notationFile fileName = pure $ 664 if P.rangeFile (getRange notation) == Strict.Just fileName 665 then mconcat $ map genPartFile notation 666 else mempty 667 where 668 notation = theNotation $ A.nameFixity $ A.qnameName x 669 670 boundAspect = nameAsp Bound False 671 672 genPartFile (BindHole r i) = several [rToR r, rToR $ getRange i] boundAspect 673 genPartFile (NormalHole r i) = several [rToR r, rToR $ getRange i] boundAspect 674 genPartFile WildHole{} = mempty 675 genPartFile (IdPart x) = H.singleton (rToR $ getRange x) (asp False) 676 677-- * Short auxiliary functions. 678--------------------------------------------------------------------------- 679 680singleAspect :: HasRange a => Aspect -> a -> Hiliter 681singleAspect a x = pure $ H.singleton (rToR $ getRange x) $ parserBased { aspect = Just a } 682 683singleOtherAspect :: HasRange a => OtherAspect -> a -> Hiliter 684singleOtherAspect a x = pure $ H.singleton (rToR $ getRange x) $ parserBased { otherAspects = singleton a } 685 686nameAsp' :: Maybe NameKind -> Bool -> Aspects 687nameAsp' k isOp = parserBased { aspect = Just $ Name k isOp } 688 689nameAsp :: NameKind -> Bool -> Aspects 690nameAsp = nameAsp' . Just 691 692concreteBase :: A.QName -> C.Name 693concreteBase = A.nameConcrete . A.qnameName 694 695concreteQualifier :: A.QName -> [C.Name] 696concreteQualifier = map A.nameConcrete . A.mnameToList . A.qnameModule 697 698bindingSite :: A.QName -> Range 699bindingSite = A.nameBindingSite . A.qnameName 700