-- | Extract highlighting syntax from abstract syntax.
--
-- Implements one big fold over abstract syntax.

-- {-# OPTIONS_GHC -fwarn-unused-imports #-}  -- Data.Semigroup is redundant in later GHC versions
{-# OPTIONS_GHC -fwarn-unused-binds   #-}

module Agda.Interaction.Highlighting.FromAbstract
  ( runHighlighter
  , NameKinds
  ) where

import Prelude hiding (null)

import Control.Applicative
import Control.Monad         ( (<=<) )
import Control.Monad.Reader  ( MonadReader(..), asks, Reader, runReader )

import qualified Data.Map      as Map
import           Data.Maybe
import           Data.Semigroup       ( Semigroup(..) )          -- for ghc 8.0
import           Data.Void            ( Void )

import           Agda.Interaction.Highlighting.Precise hiding ( singleton )
import qualified Agda.Interaction.Highlighting.Precise as H
import           Agda.Interaction.Highlighting.Range   ( rToR )  -- Range is ambiguous

import           Agda.Syntax.Abstract                ( IsProjP(..) )
import qualified Agda.Syntax.Abstract      as A
import           Agda.Syntax.Common        as Common
import           Agda.Syntax.Concrete                ( FieldAssignment'(..) )
import qualified Agda.Syntax.Concrete.Name as C
import           Agda.Syntax.Info                    ( ModuleInfo(..) )
import           Agda.Syntax.Literal
import qualified Agda.Syntax.Position      as P
import           Agda.Syntax.Position                ( Range, HasRange, getRange, noRange )
import           Agda.Syntax.Scope.Base              ( AbstractName(..), ResolvedName(..), exactConName )

import Agda.TypeChecking.Monad
  hiding (ModuleInfo, MetaInfo, Primitive, Constructor, Record, Function, Datatype)

import           Agda.Utils.FileName
import           Agda.Utils.Function
import           Agda.Utils.Functor
import           Agda.Utils.List                     ( initLast1 )
import           Agda.Utils.List1                    ( List1 )
import qualified Agda.Utils.List1          as List1
import           Agda.Utils.Maybe
import qualified Agda.Utils.Maybe.Strict   as Strict
import           Agda.Utils.Pretty
import           Agda.Utils.Singleton

-- Entry point:
-- | Create highlighting info for some piece of syntax.
runHighlighter ::
  Hilite a =>
  SourceToModule -> AbsolutePath -> NameKinds -> a ->
  HighlightingInfoBuilder
runHighlighter :: forall a.
Hilite a =>
SourceToModule
-> AbsolutePath -> NameKinds -> a -> HighlightingInfoBuilder
runHighlighter SourceToModule
modMap AbsolutePath
fileName NameKinds
kinds a
x =
  Hiliter -> HiliteEnv -> HighlightingInfoBuilder
forall r a. Reader r a -> r -> a
runReader (a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite a
x) (HiliteEnv -> HighlightingInfoBuilder)
-> HiliteEnv -> HighlightingInfoBuilder
forall a b. (a -> b) -> a -> b
$
  HiliteEnv
    { hleNameKinds :: NameKinds
hleNameKinds = NameKinds
kinds
    , hleModMap :: SourceToModule
hleModMap    = SourceToModule
modMap
    , hleFileName :: AbsolutePath
hleFileName  = AbsolutePath
fileName
    }

-- | Environment of the highlighter.
data HiliteEnv = HiliteEnv
  { HiliteEnv -> NameKinds
hleNameKinds :: NameKinds
      -- ^ Function mapping qualified names to their kind.
  , HiliteEnv -> SourceToModule
hleModMap    :: SourceToModule
      -- ^ Maps source file paths to module names.
  , HiliteEnv -> AbsolutePath
hleFileName  :: AbsolutePath
      -- ^ The file name of the current module. Used for consistency checking.
  }

-- | A function mapping names to the kind of name they stand for.
type NameKinds = A.QName -> Maybe NameKind

-- | Highlighting monad.
type HiliteM = Reader HiliteEnv

-- | Highlighter.

type Hiliter = HiliteM HighlightingInfoBuilder

instance Monoid Hiliter where
  mempty :: Hiliter
mempty  = HighlightingInfoBuilder -> Hiliter
forall (f :: * -> *) a. Applicative f => a -> f a
pure HighlightingInfoBuilder
forall a. Monoid a => a
mempty
  mappend :: Hiliter -> Hiliter -> Hiliter
mappend = Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
(<>)

-- | Traversal to extract highlighting information.

class Hilite a where
  hilite :: a -> Hiliter

  default hilite :: (Foldable t, Hilite b, t b ~ a) => a -> Hiliter
  hilite = (b -> Hiliter) -> t b -> Hiliter
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap b -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite

-- * Generic instances
---------------------------------------------------------------------------

instance Hilite a => Hilite [a]
instance Hilite a => Hilite (List1 a)
instance Hilite a => Hilite (Maybe a)
instance Hilite a => Hilite (WithHiding a)

instance Hilite Void where
  hilite :: Void -> Hiliter
hilite Void
_ = Hiliter
forall a. Monoid a => a
mempty

instance (Hilite a, Hilite b) => Hilite (Either a b) where
  hilite :: Either a b -> Hiliter
hilite = (a -> Hiliter) -> (b -> Hiliter) -> Either a b -> Hiliter
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite b -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite

instance (Hilite a, Hilite b) => Hilite (a, b) where
  hilite :: (a, b) -> Hiliter
hilite (a
a, b
b) = a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite a
a Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> b -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite b
b

-- * Major syntactic categories
---------------------------------------------------------------------------

-- | Reengineered from the old Geniplate-implemented highlighting extraction.
-- This was the old procedure:
--
-- Traversal over declaration in abstract syntax that collects the
-- following hiliting information:
--
-- [1. @constructorInfo@ (highest prio)]
-- 2. @theRest@ (medium prio)
-- 3. @nameInfo@ (lowest prio)
--
-- @nameInfo@:
--   "All names mentioned in the syntax tree (not bound variables)."
-- For each possibly ambiguous name (QName and AmbiguousQName)
-- that not isExtendedLambdaName,
-- do @hiliteAmbiguous@ (used to be called@generate@).
--
-- @constructorInfo@ (only when highlighting level == Full):
--   "After the code has been type checked more information may be
--   available for overloaded constructors, and
--   generateConstructorInfo takes advantage of this information.
--   Note, however, that highlighting for overloaded constructors is
--   included also in nameInfo."
-- This is not computed by recursion over the abstract syntax,
-- but gets the constructor names stDisambiguatedNames
-- that fall within the bounds of the current declaration.
--
-- @theRest@:
--   Bound variables, dotted patterns, record fields, module names,
--   the "as" and "to" symbols and some other things.
--
-- Here is a table what @theRest@ used to collect:
--
-- ---------------------------------------------------------------------
-- | A.Expr
-- ---------------------------------------------------------------------
-- | getVarAndField (Expr) | A.Var                       | bound
-- | getVarAndField        | A.Rec(Update)               | field
-- | getExpr        (Expr) | A.PatternSyn                | patsyn
-- | getExpr               | A.Macro                     | macro
-- ---------------------------------------------------------------------
-- | A.LetBinding
-- ---------------------------------------------------------------------
-- | getLet                | A.LetBind                   | bound
-- | getLet                | A.LetDeclaredVariable       | bound
-- ---------------------------------------------------------------------
-- | A.LamBinding
-- ---------------------------------------------------------------------
-- | getLam                | A.Binder under A.DomainFree | bound
-- | getTyped              | A.Binder under A.TBind      | bound
-- ---------------------------------------------------------------------
-- | A.Pattern'
-- ---------------------------------------------------------------------
-- | getPattern(Syn)       | A.VarP                      | bound
-- | getPattern(Syn)       | A.AsP                       | bound
-- | getPattern(Syn)       | A.DotP (not isProjP)        | DottedPattern
-- | getPattern(Syn)       | A.RecP                      | field
-- | getPattern(Syn)       | A.PatternSynP               | patsyn
-- ---------------------------------------------------------------------
-- | A.Declaration
-- ---------------------------------------------------------------------
-- | getFieldDecl          | A.Field under A.RecDef      | field
-- | getPatSynArgs         | A.PatternSynDef             | bound
-- | getPragma             | A.BuiltinPragma...          | keyword
-- ---------------------------------------------------------------------
-- | A.NamedArg (polymorphism not supported in geniplate)
-- ---------------------------------------------------------------------
-- | getNamedArg           | NamedArg a                  | nameOf
-- | getNamedArgE          | NamedArg Exp                | nameOf
-- | getNamedArgP          | NamedArg Pattern            | nameOf
-- | getNamedArgB          | NamedArg BindName           | nameOf
-- | getNamedArgL          | NamedArg LHSCore            | nameOf
--
-- | getModuleName         | A.MName                     | mod
-- | getModuleInfo         | ModuleInfo                  | asName, (range of as,to)
-- | getQuantityAttr       | Common.Quantity             | Symbol (if range)

instance Hilite A.RecordDirectives where
  hilite :: RecordDirectives -> Hiliter
hilite (RecordDirectives Maybe (Ranged Induction)
_ Maybe HasEta0
_ Maybe Range
_ Maybe QName
c) = Maybe QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite Maybe QName
c

instance Hilite A.Declaration where
  hilite :: Declaration -> Hiliter
hilite = \case
      A.Axiom KindOfName
_ax DefInfo
_di ArgInfo
ai Maybe [Occurrence]
_occ QName
x Expr
e            -> ArgInfo -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ArgInfo
ai Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl QName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
      A.Generalize Set QName
_names DefInfo
_di ArgInfo
ai QName
x Expr
e         -> ArgInfo -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ArgInfo
ai Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl QName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
      A.Field DefInfo
_di QName
x Arg Expr
e                        -> QName -> Hiliter
hlField QName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Arg Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Arg Expr
e
      A.Primitive DefInfo
_di QName
x Arg Expr
e                    -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl QName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Arg Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Arg Expr
e
      A.Mutual MutualInfo
_mi [Declaration]
ds                        -> [Declaration] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [Declaration]
ds
      A.Section Range
_r ModuleName
x GeneralizeTelescope
tel [Declaration]
ds                  -> ModuleName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ModuleName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> GeneralizeTelescope -> Hiliter
forall a. Hilite a => a -> Hiliter
hl GeneralizeTelescope
tel Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [Declaration] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [Declaration]
ds
      A.Apply ModuleInfo
mi ModuleName
x ModuleApplication
a ScopeCopyInfo
_ci ImportDirective
dir                 -> ModuleInfo -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ModuleInfo
mi Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ModuleName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ModuleName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ModuleApplication -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ModuleApplication
a Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ImportDirective -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ImportDirective
dir
      A.Import ModuleInfo
mi ModuleName
x ImportDirective
dir                      -> ModuleInfo -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ModuleInfo
mi Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ModuleName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ModuleName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ImportDirective -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ImportDirective
dir
      A.Open ModuleInfo
mi ModuleName
x ImportDirective
dir                        -> ModuleInfo -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ModuleInfo
mi Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ModuleName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ModuleName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ImportDirective -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ImportDirective
dir
      A.FunDef DefInfo
_di QName
x Delayed
_delayed [Clause]
cs             -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl QName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [Clause] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [Clause]
cs
      A.DataSig DefInfo
_di QName
x GeneralizeTelescope
tel Expr
e                  -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl QName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> GeneralizeTelescope -> Hiliter
forall a. Hilite a => a -> Hiliter
hl GeneralizeTelescope
tel Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
      A.DataDef DefInfo
_di QName
x UniverseCheck
_uc DataDefParams
pars [Declaration]
cs            -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl QName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> DataDefParams -> Hiliter
forall a. Hilite a => a -> Hiliter
hl DataDefParams
pars Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [Declaration] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [Declaration]
cs
      A.RecSig DefInfo
_di QName
x GeneralizeTelescope
tel Expr
e                   -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl QName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> GeneralizeTelescope -> Hiliter
forall a. Hilite a => a -> Hiliter
hl GeneralizeTelescope
tel Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
      A.RecDef DefInfo
_di QName
x UniverseCheck
_uc RecordDirectives
dir DataDefParams
bs Expr
e [Declaration]
ds         -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl QName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> RecordDirectives -> Hiliter
forall a. Hilite a => a -> Hiliter
hl RecordDirectives
dir Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> DataDefParams -> Hiliter
forall a. Hilite a => a -> Hiliter
hl DataDefParams
bs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [Declaration] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [Declaration]
ds
      A.PatternSynDef QName
x [Arg BindName]
xs Pattern' Void
p                 -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl QName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [Arg BindName] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [Arg BindName]
xs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Pattern' Void -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Pattern' Void
p
      A.UnquoteDecl MutualInfo
_mi [DefInfo]
_di [QName]
xs Expr
e             -> [QName] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [QName]
xs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
      A.UnquoteDef [DefInfo]
_di [QName]
xs Expr
e                  -> [QName] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [QName]
xs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
      A.ScopedDecl ScopeInfo
s [Declaration]
ds                      -> [Declaration] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [Declaration]
ds
      A.Pragma Range
_r Pragma
pragma                     -> Pragma -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Pragma
pragma
    where
    hl :: a -> Hiliter
hl      a
a = a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite a
a
    hlField :: QName -> Hiliter
hlField QName
x = [Name] -> Name -> Maybe Range -> Hiliter
hiliteField (QName -> [Name]
concreteQualifier QName
x) (QName -> Name
concreteBase QName
x) (Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Maybe Range) -> Range -> Maybe Range
forall a b. (a -> b) -> a -> b
$ QName -> Range
bindingSite QName
x)

instance Hilite A.Pragma where
  hilite :: Pragma -> Hiliter
hilite = \case
    A.OptionsPragma [String]
_strings     -> Hiliter
forall a. Monoid a => a
mempty
    A.BuiltinPragma RString
b ResolvedName
x          -> Aspect -> RString -> Hiliter
forall a. HasRange a => Aspect -> a -> Hiliter
singleAspect Aspect
Keyword RString
b Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ResolvedName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite ResolvedName
x
    A.BuiltinNoDefPragma RString
b KindOfName
k QName
x   -> Aspect -> RString -> Hiliter
forall a. HasRange a => Aspect -> a -> Hiliter
singleAspect Aspect
Keyword RString
b Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Maybe NameKind -> QName -> Hiliter
hiliteQName (NameKind -> Maybe NameKind
forall a. a -> Maybe a
Just (NameKind -> Maybe NameKind) -> NameKind -> Maybe NameKind
forall a b. (a -> b) -> a -> b
$ KindOfName -> NameKind
kindOfNameToNameKind KindOfName
k) QName
x
    A.CompilePragma RString
b QName
x String
_foreign -> Aspect -> RString -> Hiliter
forall a. HasRange a => Aspect -> a -> Hiliter
singleAspect Aspect
Keyword RString
b Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite QName
x
    A.RewritePragma Range
r [QName]
xs         -> Aspect -> Range -> Hiliter
forall a. HasRange a => Aspect -> a -> Hiliter
singleAspect Aspect
Keyword Range
r Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [QName] -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite [QName]
xs
    A.StaticPragma QName
x             -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite QName
x
    A.EtaPragma QName
x                -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite QName
x
    A.InjectivePragma QName
x          -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite QName
x
    A.InlinePragma Bool
_inline QName
x     -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite QName
x
    A.DisplayPragma QName
x [NamedArg Pattern]
ps Expr
e       -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite QName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [NamedArg Pattern] -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite [NamedArg Pattern]
ps Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite Expr
e

instance Hilite A.Expr where
  hilite :: Expr -> Hiliter
hilite = \case
      A.Var Name
x                       -> BindName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl (BindName -> Hiliter) -> BindName -> Hiliter
forall a b. (a -> b) -> a -> b
$ Name -> BindName
A.BindName Name
x        -- bound variable like binder
      A.Def' QName
q Suffix
_                    -> Maybe NameKind -> QName -> Hiliter
hiliteQName Maybe NameKind
forall a. Maybe a
Nothing QName
q
      A.Proj ProjOrigin
_o AmbiguousQName
qs                  -> Maybe NameKind -> AmbiguousQName -> Hiliter
hiliteAmbiguousQName Maybe NameKind
forall a. Maybe a
Nothing AmbiguousQName
qs  -- Issue #4604: not: hiliteProjection qs
                                         -- Names from @open R r@ should not be highlighted as projections
      A.Con AmbiguousQName
qs                      -> Maybe NameKind -> AmbiguousQName -> Hiliter
hiliteAmbiguousQName Maybe NameKind
forall a. Maybe a
Nothing AmbiguousQName
qs  -- TODO? Con aspect
      A.PatternSyn AmbiguousQName
qs               -> AmbiguousQName -> Hiliter
hilitePatternSynonym AmbiguousQName
qs
      A.Macro QName
q                     -> Maybe NameKind -> QName -> Hiliter
hiliteQName (NameKind -> Maybe NameKind
forall a. a -> Maybe a
Just NameKind
Macro) QName
q
      A.Lit ExprInfo
_r Literal
l                    -> Literal -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Literal
l
      A.QuestionMark MetaInfo
_mi InteractionId
_ii        -> Hiliter
forall a. Monoid a => a
mempty
      A.Underscore MetaInfo
_mi              -> Hiliter
forall a. Monoid a => a
mempty
      A.Dot ExprInfo
_r Expr
e                    -> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e                   -- TODO? Projection?
      A.App AppInfo
_r Expr
e NamedArg Expr
es                 -> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> NamedArg Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl NamedArg Expr
es
      A.WithApp ExprInfo
_r Expr
e [Expr]
es             -> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [Expr] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [Expr]
es
      A.Lam ExprInfo
_r LamBinding
bs Expr
e                 -> LamBinding -> Hiliter
forall a. Hilite a => a -> Hiliter
hl LamBinding
bs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
      A.AbsurdLam ExprInfo
_r Hiding
_h             -> Hiliter
forall a. Monoid a => a
mempty
      A.ExtendedLam ExprInfo
_r DefInfo
_di Erased
_e QName
_q List1 Clause
cs -> List1 Clause -> Hiliter
forall a. Hilite a => a -> Hiliter
hl List1 Clause
cs -- No hilighting of generated extended lambda name!
      A.Pi ExprInfo
_r Telescope1
tel Expr
b                 -> Telescope1 -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Telescope1
tel Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
b
      A.Generalized Set QName
_qs Expr
e           -> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
      A.Fun ExprInfo
_r Arg Expr
a Expr
b                  -> Arg Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Arg Expr
a Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
b
      A.Let ExprInfo
_r List1 LetBinding
bs Expr
e                 -> List1 LetBinding -> Hiliter
forall a. Hilite a => a -> Hiliter
hl List1 LetBinding
bs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
      A.ETel Telescope
_tel                   -> Hiliter
forall a. Monoid a => a
mempty  -- Printing only construct
      A.Rec ExprInfo
_r RecordAssigns
ass                  -> RecordAssigns -> Hiliter
forall a. Hilite a => a -> Hiliter
hl RecordAssigns
ass
      A.RecUpdate ExprInfo
_r Expr
e Assigns
ass          -> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Assigns -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Assigns
ass
      A.ScopedExpr ScopeInfo
_ Expr
e              -> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
      A.Quote ExprInfo
_r                    -> Hiliter
forall a. Monoid a => a
mempty
      A.QuoteTerm ExprInfo
_r                -> Hiliter
forall a. Monoid a => a
mempty
      A.Unquote ExprInfo
_r                  -> Hiliter
forall a. Monoid a => a
mempty
      A.DontCare Expr
e                  -> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
    where
    hl :: a -> Hiliter
hl a
a = a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite a
a

instance (Hilite a, IsProjP a) => Hilite (A.Pattern' a) where
  hilite :: Pattern' a -> Hiliter
hilite = \case
      A.VarP BindName
x               -> BindName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl BindName
x
      A.ConP ConPatInfo
_i AmbiguousQName
qs NAPs a
es        -> AmbiguousQName -> Hiliter
hiliteInductiveConstructor AmbiguousQName
qs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> NAPs a -> Hiliter
forall a. Hilite a => a -> Hiliter
hl NAPs a
es
        -- No matching on coinductive constructors, thus, can determine NameKind here.
      A.ProjP PatInfo
_r ProjOrigin
_o AmbiguousQName
qs       -> AmbiguousQName -> Hiliter
hiliteProjection AmbiguousQName
qs
      A.DefP PatInfo
_r AmbiguousQName
qs NAPs a
es        -> AmbiguousQName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl AmbiguousQName
qs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> NAPs a -> Hiliter
forall a. Hilite a => a -> Hiliter
hl NAPs a
es
      A.WildP PatInfo
_r             -> Hiliter
forall a. Monoid a => a
mempty
      A.AsP PatInfo
_r BindName
x Pattern' a
p           -> BindName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl BindName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Pattern' a -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Pattern' a
p
      A.DotP PatInfo
r a
e             -> case a -> Maybe (ProjOrigin, AmbiguousQName)
forall a. IsProjP a => a -> Maybe (ProjOrigin, AmbiguousQName)
isProjP a
e of
                                  Maybe (ProjOrigin, AmbiguousQName)
Nothing       -> OtherAspect -> PatInfo -> Hiliter
forall a. HasRange a => OtherAspect -> a -> Hiliter
singleOtherAspect OtherAspect
DottedPattern PatInfo
r Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> a -> Hiliter
forall a. Hilite a => a -> Hiliter
hl a
e
                                  Just (ProjOrigin
_o, AmbiguousQName
qs) -> AmbiguousQName -> Hiliter
hiliteProjection AmbiguousQName
qs
      A.AbsurdP PatInfo
_r           -> Hiliter
forall a. Monoid a => a
mempty
      A.LitP PatInfo
_r Literal
l            -> Literal -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Literal
l
      A.PatternSynP PatInfo
_r AmbiguousQName
qs NAPs a
es -> AmbiguousQName -> Hiliter
hilitePatternSynonym AmbiguousQName
qs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> NAPs a -> Hiliter
forall a. Hilite a => a -> Hiliter
hl NAPs a
es
      A.RecP PatInfo
_r [FieldAssignment' (Pattern' a)]
ps           -> [FieldAssignment' (Pattern' a)] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [FieldAssignment' (Pattern' a)]
ps
      A.EqualP PatInfo
_r [(a, a)]
ps         -> [(a, a)] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [(a, a)]
ps
      A.WithP PatInfo
_ Pattern' a
p            -> Pattern' a -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Pattern' a
p
      A.AnnP PatInfo
_r a
a Pattern' a
p          -> Pattern' a -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Pattern' a
p

    where
    hl :: a -> Hiliter
hl a
a = a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite a
a

instance Hilite Literal where
  hilite :: Literal -> Hiliter
hilite = \case
    LitNat{}                 -> Hiliter
forall a. Monoid a => a
mempty
    LitWord64{}              -> Hiliter
forall a. Monoid a => a
mempty
    LitFloat{}               -> Hiliter
forall a. Monoid a => a
mempty
    LitString{}              -> Hiliter
forall a. Monoid a => a
mempty
    LitChar{}                -> Hiliter
forall a. Monoid a => a
mempty
    LitQName QName
x               -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite QName
x
    LitMeta AbsolutePath
_fileName MetaId
_id    -> Hiliter
forall a. Monoid a => a
mempty

-- * Minor syntactic categories
---------------------------------------------------------------------------

instance Hilite A.LHS where
  hilite :: LHS -> Hiliter
hilite (A.LHS LHSInfo
_r LHSCore
lhs) = LHSCore -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite LHSCore
lhs

instance (Hilite a, IsProjP a) => Hilite (A.LHSCore' a) where
  hilite :: LHSCore' a -> Hiliter
hilite = \case
    A.LHSHead QName
q [NamedArg (Pattern' a)]
ps       -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite QName
q   Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [NamedArg (Pattern' a)] -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite [NamedArg (Pattern' a)]
ps
    A.LHSProj AmbiguousQName
q NamedArg (LHSCore' a)
lhs [NamedArg (Pattern' a)]
ps   -> NamedArg (LHSCore' a) -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite NamedArg (LHSCore' a)
lhs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> AmbiguousQName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite AmbiguousQName
q   Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [NamedArg (Pattern' a)] -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite [NamedArg (Pattern' a)]
ps -- TODO? Projection?
    A.LHSWith LHSCore' a
lhs [Arg (Pattern' a)]
wps [NamedArg (Pattern' a)]
ps -> LHSCore' a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite LHSCore' a
lhs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [Arg (Pattern' a)] -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite [Arg (Pattern' a)]
wps Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [NamedArg (Pattern' a)] -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite [NamedArg (Pattern' a)]
ps

instance Hilite A.RHS where
  hilite :: RHS -> Hiliter
hilite = \case
      A.RHS Expr
e Maybe Expr
_ce                          -> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
      RHS
A.AbsurdRHS                          -> Hiliter
forall a. Monoid a => a
mempty
      A.WithRHS QName
_q [WithExpr]
es [Clause]
cs                   -> [WithExpr] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [WithExpr]
es  Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [Clause] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [Clause]
cs  -- No highlighting for with-function-name!
      A.RewriteRHS [RewriteEqn]
eqs [ProblemEq]
strippedPats RHS
rhs WhereDeclarations
wh -> [RewriteEqn] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [RewriteEqn]
eqs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [ProblemEq] -> Hiliter
forall a. Hilite a => a -> Hiliter
hl [ProblemEq]
strippedPats Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> RHS -> Hiliter
forall a. Hilite a => a -> Hiliter
hl RHS
rhs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> WhereDeclarations -> Hiliter
forall a. Hilite a => a -> Hiliter
hl WhereDeclarations
wh
    where
    hl :: a -> Hiliter
hl a
a = a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite a
a

instance (HasRange n, Hilite p, Hilite e) => Hilite (RewriteEqn' x n p e) where
  hilite :: RewriteEqn' x n p e -> Hiliter
hilite = \case
    Rewrite List1 (x, e)
es    -> NonEmpty e -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite (NonEmpty e -> Hiliter) -> NonEmpty e -> Hiliter
forall a b. (a -> b) -> a -> b
$ ((x, e) -> e) -> List1 (x, e) -> NonEmpty e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (x, e) -> e
forall a b. (a, b) -> b
snd List1 (x, e)
es
    Invert x
_x List1 (Named n (p, e))
pes -> List1 (Named n (p, e)) -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite List1 (Named n (p, e))
pes

instance Hilite a => Hilite (A.Clause' a) where
  hilite :: Clause' a -> Hiliter
hilite (A.Clause a
lhs [ProblemEq]
strippedPats RHS
rhs WhereDeclarations
wh Bool
_catchall) =
    a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite a
lhs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [ProblemEq] -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite [ProblemEq]
strippedPats Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> RHS -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite RHS
rhs Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> WhereDeclarations -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite WhereDeclarations
wh

instance Hilite A.ProblemEq where
  hilite :: ProblemEq -> Hiliter
hilite (A.ProblemEq Pattern
p Term
_t Dom Type
_dom) = Pattern -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite Pattern
p

instance Hilite A.WhereDeclarations where
  hilite :: WhereDeclarations -> Hiliter
hilite (A.WhereDecls Maybe ModuleName
m Maybe Declaration
ds) = Maybe ModuleName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite Maybe ModuleName
m Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Maybe Declaration -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite Maybe Declaration
ds

instance Hilite A.GeneralizeTelescope where
  hilite :: GeneralizeTelescope -> Hiliter
hilite (A.GeneralizeTel Map QName Name
_gen Telescope
tel) = Telescope -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite Telescope
tel

instance Hilite A.DataDefParams where
  hilite :: DataDefParams -> Hiliter
hilite (A.DataDefParams Set Name
_gen [LamBinding]
pars) = [LamBinding] -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite [LamBinding]
pars

instance Hilite A.ModuleApplication where
  hilite :: ModuleApplication -> Hiliter
hilite = \case
    A.SectionApp Telescope
tel ModuleName
x [NamedArg Expr]
es    -> Telescope -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite Telescope
tel Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ModuleName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite ModuleName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> [NamedArg Expr] -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite [NamedArg Expr]
es
    A.RecordModuleInstance ModuleName
x -> ModuleName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite ModuleName
x

instance Hilite A.LetBinding where
  hilite :: LetBinding -> Hiliter
hilite = \case
      A.LetBind    LetInfo
_r ArgInfo
ai BindName
x Expr
t Expr
e     -> ArgInfo -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ArgInfo
ai Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> BindName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl BindName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
t Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
      A.LetPatBind LetInfo
_r Pattern
p Expr
e          -> Pattern -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Pattern
p  Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hl Expr
e
      A.LetApply   ModuleInfo
mi ModuleName
x ModuleApplication
es ScopeCopyInfo
_ci ImportDirective
dir -> ModuleInfo -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ModuleInfo
mi Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ModuleName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ModuleName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ModuleApplication -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ModuleApplication
es Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ImportDirective -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ImportDirective
dir
      A.LetOpen    ModuleInfo
mi ModuleName
x ImportDirective
dir        -> ModuleInfo -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ModuleInfo
mi Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ModuleName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ModuleName
x Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> ImportDirective -> Hiliter
forall a. Hilite a => a -> Hiliter
hl ImportDirective
dir
      A.LetDeclaredVariable BindName
x      -> BindName -> Hiliter
forall a. Hilite a => a -> Hiliter
hl BindName
x
    where
    hl :: a -> Hiliter
hl a
x = a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite a
x

instance Hilite A.TypedBinding where
  hilite :: TypedBinding -> Hiliter
hilite = \case
    A.TBind Range
_r TacticAttr
tac List1 (NamedArg Binder)
binds Expr
e -> TacticAttr -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite TacticAttr
tac Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> List1 (NamedArg Binder) -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite List1 (NamedArg Binder)
binds Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Expr -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite Expr
e
    A.TLet Range
_r List1 LetBinding
binds        -> List1 LetBinding -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite List1 LetBinding
binds

instance Hilite A.LamBinding where
  hilite :: LamBinding -> Hiliter
hilite = \case
    A.DomainFree TacticAttr
tac NamedArg Binder
binds -> TacticAttr -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite TacticAttr
tac Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> NamedArg Binder -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite NamedArg Binder
binds
    A.DomainFull TypedBinding
bind      -> TypedBinding -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite TypedBinding
bind

instance Hilite a => Hilite (A.Binder' a) where
  hilite :: Binder' a -> Hiliter
hilite (A.Binder Maybe Pattern
p a
x) = Maybe Pattern -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite Maybe Pattern
p Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite a
x

instance Hilite A.BindName where
  hilite :: BindName -> Hiliter
hilite (A.BindName Name
x) = Name -> Hiliter
hiliteBound Name
x

instance Hilite a => Hilite (FieldAssignment' a) where
  hilite :: FieldAssignment' a -> Hiliter
hilite (FieldAssignment Name
x a
e) = [Name] -> Name -> Maybe Range -> Hiliter
hiliteField [] Name
x Maybe Range
forall a. Maybe a
Nothing Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite a
e

instance (Hilite a, HasRange n) => Hilite (Named n a) where
  hilite :: Named n a -> Hiliter
hilite (Named Maybe n
mn a
e)
    =  Hiliter -> (n -> Hiliter) -> Maybe n -> Hiliter
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Hiliter
forall a. Monoid a => a
mempty (Aspect -> n -> Hiliter
forall a. HasRange a => Aspect -> a -> Hiliter
singleAspect (Aspect -> n -> Hiliter) -> Aspect -> n -> Hiliter
forall a b. (a -> b) -> a -> b
$ Maybe NameKind -> Bool -> Aspect
Name (NameKind -> Maybe NameKind
forall a. a -> Maybe a
Just NameKind
Argument) Bool
False) Maybe n
mn
    Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite a
e

instance Hilite a => Hilite (Arg a) where
  hilite :: Arg a -> Hiliter
hilite (Arg ArgInfo
ai a
e) = ArgInfo -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite ArgInfo
ai Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> a -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite a
e

instance Hilite ArgInfo where
  hilite :: ArgInfo -> Hiliter
hilite (ArgInfo Hiding
_hiding Modality
modality Origin
_origin FreeVariables
_fv Annotation
_a) = Modality -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite Modality
modality

instance Hilite Modality where
  hilite :: Modality -> Hiliter
hilite (Modality Relevance
_relevance Quantity
quantity Cohesion
_cohesion) = Quantity -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite Quantity
quantity

-- | If the 'Quantity' attribute comes with a 'Range', highlight the
-- corresponding attribute as 'Symbol'.
instance Hilite Quantity where
  hilite :: Quantity -> Hiliter
hilite = Aspect -> Quantity -> Hiliter
forall a. HasRange a => Aspect -> a -> Hiliter
singleAspect Aspect
Symbol

instance Hilite ModuleInfo where
  hilite :: ModuleInfo -> Hiliter
hilite (ModuleInfo Range
_r Range
rAsTo Maybe Name
asName Maybe OpenShortHand
_open Maybe ImportDirective
_impDir)
    =  Aspect -> Range -> Hiliter
forall a. HasRange a => Aspect -> a -> Hiliter
singleAspect Aspect
Symbol Range
rAsTo            -- TODO: 'to' already covered by A.ImportDirective
    Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Hiliter -> (Name -> Hiliter) -> Maybe Name -> Hiliter
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Hiliter
forall a. Monoid a => a
mempty Name -> Hiliter
hiliteAsName Maybe Name
asName
    -- <> hilite impDir                     -- Should be covered by A.ImportDirective
    where
    hiliteAsName :: C.Name -> Hiliter
    hiliteAsName :: Name -> Hiliter
hiliteAsName Name
n = [Name]
-> Name -> Range -> Maybe Range -> (Bool -> Aspects) -> Hiliter
hiliteCName [] Name
n Range
forall a. Range' a
noRange Maybe Range
forall a. Maybe a
Nothing ((Bool -> Aspects) -> Hiliter) -> (Bool -> Aspects) -> Hiliter
forall a b. (a -> b) -> a -> b
$ NameKind -> Bool -> Aspects
nameAsp NameKind
Module

instance (Hilite m, Hilite n, Hilite (RenamingTo m), Hilite (RenamingTo n))
       => Hilite (ImportDirective' m n) where
  hilite :: ImportDirective' m n -> Hiliter
hilite (ImportDirective Range
_r Using' m n
using HidingDirective' m n
hiding RenamingDirective' m n
renaming Maybe Range
_ropen) =
    Using' m n -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite Using' m n
using Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> HidingDirective' m n -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite HidingDirective' m n
hiding Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> RenamingDirective' m n -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite RenamingDirective' m n
renaming

instance (Hilite m, Hilite n) => Hilite (Using' m n) where
  hilite :: Using' m n -> Hiliter
hilite = \case
    Using' m n
UseEverything -> Hiliter
forall a. Monoid a => a
mempty
    Using [ImportedName' m n]
using   -> [ImportedName' m n] -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite [ImportedName' m n]
using

instance (Hilite m, Hilite n, Hilite (RenamingTo m), Hilite (RenamingTo n))
       => Hilite (Renaming' m n) where
  hilite :: Renaming' m n -> Hiliter
hilite (Renaming ImportedName' m n
from ImportedName' m n
to Maybe Fixity
_fixity Range
rangeKwTo)
    =  ImportedName' m n -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite ImportedName' m n
from
    Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> Aspect -> Range -> Hiliter
forall a. HasRange a => Aspect -> a -> Hiliter
singleAspect Aspect
Symbol Range
rangeKwTo
         -- Currently, the "to" is already highlited by rAsTo above.
         -- TODO: remove the "to" ranges from rAsTo.
    Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> RenamingTo (ImportedName' m n) -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite (ImportedName' m n -> RenamingTo (ImportedName' m n)
forall a. a -> RenamingTo a
RenamingTo ImportedName' m n
to)

instance (Hilite m, Hilite n) => Hilite (ImportedName' m n) where
  hilite :: ImportedName' m n -> Hiliter
hilite = \case
    ImportedModule n
m -> n -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite n
m
    ImportedName   m
n -> m -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite m
n

-- * Highlighting of names
---------------------------------------------------------------------------

instance Hilite DisambiguatedName where
  hilite :: DisambiguatedName -> Hiliter
hilite (DisambiguatedName NameKind
k QName
x) = Maybe NameKind -> QName -> Hiliter
hiliteQName (NameKind -> Maybe NameKind
forall a. a -> Maybe a
Just NameKind
k) QName
x

instance Hilite ResolvedName where
  hilite :: ResolvedName -> Hiliter
hilite = \case
    VarName           Name
x BindingSource
_bindSrc -> Name -> Hiliter
hiliteBound Name
x
    DefinedName  Access
_acc AbstractName
x Suffix
_suffix  -> QName -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite (QName -> Hiliter) -> QName -> Hiliter
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
x
    FieldName         List1 AbstractName
xs         -> AmbiguousQName -> Hiliter
hiliteProjection (AmbiguousQName -> Hiliter) -> AmbiguousQName -> Hiliter
forall a b. (a -> b) -> a -> b
$ List1 QName -> AmbiguousQName
A.AmbQ (List1 QName -> AmbiguousQName) -> List1 QName -> AmbiguousQName
forall a b. (a -> b) -> a -> b
$ (AbstractName -> QName) -> List1 AbstractName -> List1 QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
xs
    ConstructorName Set Induction
i List1 AbstractName
xs         -> Maybe NameKind -> AmbiguousQName -> Hiliter
hiliteAmbiguousQName Maybe NameKind
k (AmbiguousQName -> Hiliter) -> AmbiguousQName -> Hiliter
forall a b. (a -> b) -> a -> b
$ List1 QName -> AmbiguousQName
A.AmbQ (List1 QName -> AmbiguousQName) -> List1 QName -> AmbiguousQName
forall a b. (a -> b) -> a -> b
$ (AbstractName -> QName) -> List1 AbstractName -> List1 QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
xs
      where k :: Maybe NameKind
k = KindOfName -> NameKind
kindOfNameToNameKind (KindOfName -> NameKind) -> Maybe KindOfName -> Maybe NameKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Induction -> Maybe KindOfName
forall (t :: * -> *). Foldable t => t Induction -> Maybe KindOfName
exactConName Set Induction
i
    PatternSynResName List1 AbstractName
xs         -> AmbiguousQName -> Hiliter
hilitePatternSynonym (AmbiguousQName -> Hiliter) -> AmbiguousQName -> Hiliter
forall a b. (a -> b) -> a -> b
$ List1 QName -> AmbiguousQName
A.AmbQ (List1 QName -> AmbiguousQName) -> List1 QName -> AmbiguousQName
forall a b. (a -> b) -> a -> b
$ (AbstractName -> QName) -> List1 AbstractName -> List1 QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
xs
    ResolvedName
UnknownName                  -> Hiliter
forall a. Monoid a => a
mempty

instance Hilite A.QName where
  hilite :: QName -> Hiliter
hilite = Maybe NameKind -> QName -> Hiliter
hiliteQName Maybe NameKind
forall a. Maybe a
Nothing

instance Hilite A.AmbiguousQName where
  hilite :: AmbiguousQName -> Hiliter
hilite = Maybe NameKind -> AmbiguousQName -> Hiliter
hiliteAmbiguousQName Maybe NameKind
forall a. Maybe a
Nothing

instance Hilite A.ModuleName where
  hilite :: ModuleName -> Hiliter
hilite m :: ModuleName
m@(A.MName [Name]
xs) = do
    SourceToModule
modMap <- (HiliteEnv -> SourceToModule)
-> ReaderT HiliteEnv Identity SourceToModule
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HiliteEnv -> SourceToModule
hleModMap
    (Bool, ModuleName) -> Hiliter
hiliteModule (SourceToModule -> Bool
isTopLevelModule SourceToModule
modMap, ModuleName
m)
    where
    isTopLevelModule :: SourceToModule -> Bool
isTopLevelModule SourceToModule
modMap =
      case (Name -> Maybe AbsolutePath) -> [Name] -> [AbsolutePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
          ((Maybe AbsolutePath -> Maybe AbsolutePath
forall a. Maybe a -> Maybe a
Strict.toLazy (Maybe AbsolutePath -> Maybe AbsolutePath)
-> (Position' (Maybe AbsolutePath) -> Maybe AbsolutePath)
-> Position' (Maybe AbsolutePath)
-> Maybe AbsolutePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position' (Maybe AbsolutePath) -> Maybe AbsolutePath
forall a. Position' a -> a
P.srcFile) (Position' (Maybe AbsolutePath) -> Maybe AbsolutePath)
-> (Name -> Maybe (Position' (Maybe AbsolutePath)))
-> Name
-> Maybe AbsolutePath
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Range -> Maybe (Position' (Maybe AbsolutePath))
forall a. Range' a -> Maybe (Position' a)
P.rStart (Range -> Maybe (Position' (Maybe AbsolutePath)))
-> (Name -> Range)
-> Name
-> Maybe (Position' (Maybe AbsolutePath))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Range
A.nameBindingSite)) [Name]
xs of
        AbsolutePath
f : [AbsolutePath]
_ ->
          AbsolutePath -> SourceToModule -> Maybe TopLevelModuleName
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AbsolutePath
f SourceToModule
modMap
            Maybe TopLevelModuleName -> Maybe TopLevelModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== TopLevelModuleName -> Maybe TopLevelModuleName
forall a. a -> Maybe a
Just (QName -> TopLevelModuleName
C.toTopLevelModuleName (QName -> TopLevelModuleName) -> QName -> TopLevelModuleName
forall a b. (a -> b) -> a -> b
$ ModuleName -> QName
A.mnameToConcrete ModuleName
m)
        [] -> Bool
False

  -- Andreas, 2020-09-29, issue #4952.
-- The target of a @renaming@ clause needs to be highlighted in a special way.
newtype RenamingTo a = RenamingTo a

instance Hilite (RenamingTo A.QName) where
  -- Andreas, 2020-09-29, issue #4952.
  -- Do not include the bindingSite, because the HTML backed turns it into garbage.
  hilite :: RenamingTo QName -> Hiliter
hilite (RenamingTo QName
q) = do
    Maybe NameKind
kind <- (HiliteEnv -> NameKinds) -> ReaderT HiliteEnv Identity NameKinds
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HiliteEnv -> NameKinds
hleNameKinds ReaderT HiliteEnv Identity NameKinds
-> (NameKinds -> Maybe NameKind)
-> ReaderT HiliteEnv Identity (Maybe NameKind)
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (NameKinds -> NameKinds
forall a b. (a -> b) -> a -> b
$ QName
q)
    QName -> Bool -> (Bool -> Aspects) -> Hiliter
hiliteAName QName
q Bool
False ((Bool -> Aspects) -> Hiliter) -> (Bool -> Aspects) -> Hiliter
forall a b. (a -> b) -> a -> b
$ Maybe NameKind -> Bool -> Aspects
nameAsp' Maybe NameKind
kind

instance Hilite (RenamingTo A.ModuleName) where
  -- Andreas, 2020-09-29, issue #4952.
  -- Do not include the bindingSite, because the HTML backed turns it into garbage.
  hilite :: RenamingTo ModuleName -> Hiliter
hilite (RenamingTo (A.MName [Name]
ns)) = ((Name -> Hiliter) -> [Name] -> Hiliter)
-> [Name] -> (Name -> Hiliter) -> Hiliter
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> Hiliter) -> [Name] -> Hiliter
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [Name]
ns ((Name -> Hiliter) -> Hiliter) -> (Name -> Hiliter) -> Hiliter
forall a b. (a -> b) -> a -> b
$ \ Name
n ->
    [Name]
-> Name -> Range -> Maybe Range -> (Bool -> Aspects) -> Hiliter
hiliteCName [] (Name -> Name
A.nameConcrete Name
n) Range
forall a. Range' a
noRange Maybe Range
forall a. Maybe a
Nothing ((Bool -> Aspects) -> Hiliter) -> (Bool -> Aspects) -> Hiliter
forall a b. (a -> b) -> a -> b
$ NameKind -> Bool -> Aspects
nameAsp NameKind
Module

instance (Hilite (RenamingTo m), Hilite (RenamingTo n))
       => Hilite (RenamingTo (ImportedName' m n)) where
  hilite :: RenamingTo (ImportedName' m n) -> Hiliter
hilite (RenamingTo ImportedName' m n
x) = case ImportedName' m n
x of
    ImportedModule n
m -> RenamingTo n -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite (n -> RenamingTo n
forall a. a -> RenamingTo a
RenamingTo n
m)
    ImportedName   m
n -> RenamingTo m -> Hiliter
forall a. Hilite a => a -> Hiliter
hilite (m -> RenamingTo m
forall a. a -> RenamingTo a
RenamingTo m
n)

hiliteQName
  :: Maybe NameKind   -- ^ Is 'NameKind' already known from the context?
  -> A.QName
  -> Hiliter
hiliteQName :: Maybe NameKind -> QName -> Hiliter
hiliteQName Maybe NameKind
mkind QName
q
  | QName -> Bool
isExtendedLambdaName QName
q = Hiliter
forall a. Monoid a => a
mempty
  | QName -> Bool
isAbsurdLambdaName   QName
q = Hiliter
forall a. Monoid a => a
mempty
  | Bool
otherwise = do
      Maybe NameKind
kind <- Maybe NameKind
-> (NameKind -> ReaderT HiliteEnv Identity (Maybe NameKind))
-> ReaderT HiliteEnv Identity (Maybe NameKind)
-> ReaderT HiliteEnv Identity (Maybe NameKind)
forall a b. Maybe a -> (a -> b) -> b -> b
ifJust Maybe NameKind
mkind (Maybe NameKind -> ReaderT HiliteEnv Identity (Maybe NameKind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NameKind -> ReaderT HiliteEnv Identity (Maybe NameKind))
-> (NameKind -> Maybe NameKind)
-> NameKind
-> ReaderT HiliteEnv Identity (Maybe NameKind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameKind -> Maybe NameKind
forall a. a -> Maybe a
Just) {-else-} (ReaderT HiliteEnv Identity (Maybe NameKind)
 -> ReaderT HiliteEnv Identity (Maybe NameKind))
-> ReaderT HiliteEnv Identity (Maybe NameKind)
-> ReaderT HiliteEnv Identity (Maybe NameKind)
forall a b. (a -> b) -> a -> b
$ (HiliteEnv -> NameKinds) -> ReaderT HiliteEnv Identity NameKinds
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HiliteEnv -> NameKinds
hleNameKinds ReaderT HiliteEnv Identity NameKinds
-> (NameKinds -> Maybe NameKind)
-> ReaderT HiliteEnv Identity (Maybe NameKind)
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (NameKinds -> NameKinds
forall a b. (a -> b) -> a -> b
$ QName
q)
      QName -> Bool -> (Bool -> Aspects) -> Hiliter
hiliteAName QName
q Bool
True ((Bool -> Aspects) -> Hiliter) -> (Bool -> Aspects) -> Hiliter
forall a b. (a -> b) -> a -> b
$ Maybe NameKind -> Bool -> Aspects
nameAsp' Maybe NameKind
kind

-- | Takes the first 'NameKind'.  Binding site only included if unique.
hiliteAmbiguousQName
  :: Maybe NameKind   -- ^ Is 'NameKind' already known from the context?
  -> A.AmbiguousQName
  -> Hiliter
hiliteAmbiguousQName :: Maybe NameKind -> AmbiguousQName -> Hiliter
hiliteAmbiguousQName Maybe NameKind
mkind (A.AmbQ List1 QName
qs) = do
  Maybe NameKind
kind <- Maybe NameKind
-> (NameKind -> ReaderT HiliteEnv Identity (Maybe NameKind))
-> ReaderT HiliteEnv Identity (Maybe NameKind)
-> ReaderT HiliteEnv Identity (Maybe NameKind)
forall a b. Maybe a -> (a -> b) -> b -> b
ifJust Maybe NameKind
mkind (Maybe NameKind -> ReaderT HiliteEnv Identity (Maybe NameKind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NameKind -> ReaderT HiliteEnv Identity (Maybe NameKind))
-> (NameKind -> Maybe NameKind)
-> NameKind
-> ReaderT HiliteEnv Identity (Maybe NameKind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameKind -> Maybe NameKind
forall a. a -> Maybe a
Just) {-else-} (ReaderT HiliteEnv Identity (Maybe NameKind)
 -> ReaderT HiliteEnv Identity (Maybe NameKind))
-> ReaderT HiliteEnv Identity (Maybe NameKind)
-> ReaderT HiliteEnv Identity (Maybe NameKind)
forall a b. (a -> b) -> a -> b
$ do
    NameKinds
kinds <- (HiliteEnv -> NameKinds) -> ReaderT HiliteEnv Identity NameKinds
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HiliteEnv -> NameKinds
hleNameKinds
    Maybe NameKind -> ReaderT HiliteEnv Identity (Maybe NameKind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NameKind -> ReaderT HiliteEnv Identity (Maybe NameKind))
-> Maybe NameKind -> ReaderT HiliteEnv Identity (Maybe NameKind)
forall a b. (a -> b) -> a -> b
$ [NameKind] -> Maybe NameKind
forall a. [a] -> Maybe a
listToMaybe ([NameKind] -> Maybe NameKind) -> [NameKind] -> Maybe NameKind
forall a b. (a -> b) -> a -> b
$ List1 (Maybe NameKind) -> [NameKind]
forall a. List1 (Maybe a) -> [a]
List1.catMaybes (List1 (Maybe NameKind) -> [NameKind])
-> List1 (Maybe NameKind) -> [NameKind]
forall a b. (a -> b) -> a -> b
$ NameKinds -> List1 QName -> List1 (Maybe NameKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NameKinds
kinds List1 QName
qs
      -- Ulf, 2014-06-03: [issue1064] It's better to pick the first rather
      -- than doing no highlighting if there's an ambiguity between an
      -- inductive and coinductive constructor.
  ((QName -> Hiliter) -> List1 QName -> Hiliter)
-> List1 QName -> (QName -> Hiliter) -> Hiliter
forall a b c. (a -> b -> c) -> b -> a -> c
flip (QName -> Hiliter) -> List1 QName -> Hiliter
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap List1 QName
qs ((QName -> Hiliter) -> Hiliter) -> (QName -> Hiliter) -> Hiliter
forall a b. (a -> b) -> a -> b
$ \ QName
q ->
    QName -> Bool -> (Bool -> Aspects) -> Hiliter
hiliteAName QName
q Bool
include ((Bool -> Aspects) -> Hiliter) -> (Bool -> Aspects) -> Hiliter
forall a b. (a -> b) -> a -> b
$ Maybe NameKind -> Bool -> Aspects
nameAsp' Maybe NameKind
kind
  where
  include :: Bool
include = List1 Range -> Bool
forall a. Eq a => List1 a -> Bool
List1.allEqual (List1 Range -> Bool) -> List1 Range -> Bool
forall a b. (a -> b) -> a -> b
$ (QName -> Range) -> List1 QName -> List1 Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap QName -> Range
bindingSite List1 QName
qs

hiliteBound :: A.Name -> Hiliter
hiliteBound :: Name -> Hiliter
hiliteBound Name
x =
  [Name]
-> Name -> Range -> Maybe Range -> (Bool -> Aspects) -> Hiliter
hiliteCName [] (Name -> Name
A.nameConcrete Name
x) Range
forall a. Range' a
noRange (Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Maybe Range) -> Range -> Maybe Range
forall a b. (a -> b) -> a -> b
$ Name -> Range
A.nameBindingSite Name
x) ((Bool -> Aspects) -> Hiliter) -> (Bool -> Aspects) -> Hiliter
forall a b. (a -> b) -> a -> b
$ NameKind -> Bool -> Aspects
nameAsp NameKind
Bound

hiliteInductiveConstructor :: A.AmbiguousQName -> Hiliter
hiliteInductiveConstructor :: AmbiguousQName -> Hiliter
hiliteInductiveConstructor = Maybe NameKind -> AmbiguousQName -> Hiliter
hiliteAmbiguousQName (Maybe NameKind -> AmbiguousQName -> Hiliter)
-> Maybe NameKind -> AmbiguousQName -> Hiliter
forall a b. (a -> b) -> a -> b
$ NameKind -> Maybe NameKind
forall a. a -> Maybe a
Just (NameKind -> Maybe NameKind) -> NameKind -> Maybe NameKind
forall a b. (a -> b) -> a -> b
$ Induction -> NameKind
Constructor Induction
Inductive

hilitePatternSynonym :: A.AmbiguousQName -> Hiliter
hilitePatternSynonym :: AmbiguousQName -> Hiliter
hilitePatternSynonym = AmbiguousQName -> Hiliter
hiliteInductiveConstructor  -- There are no coinductive pattern synonyms!?

hiliteProjection :: A.AmbiguousQName -> Hiliter
hiliteProjection :: AmbiguousQName -> Hiliter
hiliteProjection = Maybe NameKind -> AmbiguousQName -> Hiliter
hiliteAmbiguousQName (NameKind -> Maybe NameKind
forall a. a -> Maybe a
Just NameKind
Field)

hiliteField :: [C.Name] -> C.Name -> Maybe Range -> Hiliter
hiliteField :: [Name] -> Name -> Maybe Range -> Hiliter
hiliteField [Name]
xs Name
x Maybe Range
bindingR = [Name]
-> Name -> Range -> Maybe Range -> (Bool -> Aspects) -> Hiliter
hiliteCName [Name]
xs Name
x Range
forall a. Range' a
noRange Maybe Range
bindingR ((Bool -> Aspects) -> Hiliter) -> (Bool -> Aspects) -> Hiliter
forall a b. (a -> b) -> a -> b
$ NameKind -> Bool -> Aspects
nameAsp NameKind
Field

-- For top level modules, we set the binding site to the beginning of the file
-- so that clicking on an imported module will jump to the beginning of the file
-- which defines this module.
hiliteModule :: (Bool, A.ModuleName) -> Hiliter
hiliteModule :: (Bool, ModuleName) -> Hiliter
hiliteModule (Bool
isTopLevelModule, A.MName []) = Hiliter
forall a. Monoid a => a
mempty
hiliteModule (Bool
isTopLevelModule, A.MName (Name
n:[Name]
ns)) =
  [Name]
-> Name -> Range -> Maybe Range -> (Bool -> Aspects) -> Hiliter
hiliteCName
    ((Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Name
A.nameConcrete [Name]
ms)
    (Name -> Name
A.nameConcrete Name
m)
    Range
forall a. Range' a
noRange
    Maybe Range
mR
    (NameKind -> Bool -> Aspects
nameAsp NameKind
Module)
  where
  ([Name]
ms, Name
m) = Name -> [Name] -> ([Name], Name)
forall a. a -> [a] -> ([a], a)
initLast1 Name
n [Name]
ns
  mR :: Maybe Range
mR = Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Maybe Range) -> Range -> Maybe Range
forall a b. (a -> b) -> a -> b
$
       Bool -> (Range -> Range) -> Range -> Range
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
isTopLevelModule Range -> Range
P.beginningOfFile (Range -> Range) -> Range -> Range
forall a b. (a -> b) -> a -> b
$
       Name -> Range
A.nameBindingSite Name
m

-- This was Highlighting.Generate.nameToFile:
-- | Converts names to suitable 'File's.
hiliteCName
  :: [C.Name]
     -- ^ The name qualifier (may be empty).
  -> C.Name     -- ^ The base name.
  -> Range
     -- ^ The 'Range' of the name in its fixity declaration (if any).
  -> Maybe Range
     -- ^ The definition site of the name. The calculated
     --   meta information is extended with this information, if possible.
  -> (Bool -> Aspects)
     -- ^ Meta information to be associated with the name.
     --   The argument is 'True' iff the name is an operator.
  -> Hiliter
hiliteCName :: [Name]
-> Name -> Range -> Maybe Range -> (Bool -> Aspects) -> Hiliter
hiliteCName [Name]
xs Name
x Range
fr Maybe Range
mR Bool -> Aspects
asp = do
  HiliteEnv NameKinds
_ SourceToModule
modMap AbsolutePath
fileName <- ReaderT HiliteEnv Identity HiliteEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  -- We don't care if we get any funny ranges.
  if (Maybe AbsolutePath -> Bool) -> [Maybe AbsolutePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe AbsolutePath -> Maybe AbsolutePath -> Bool
forall a. Eq a => a -> a -> Bool
== AbsolutePath -> Maybe AbsolutePath
forall a. a -> Maybe a
Strict.Just AbsolutePath
fileName) [Maybe AbsolutePath]
fileNames then HighlightingInfoBuilder -> Hiliter
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HighlightingInfoBuilder -> Hiliter)
-> HighlightingInfoBuilder -> Hiliter
forall a b. (a -> b) -> a -> b
$
    SourceToModule -> HighlightingInfoBuilder
frFile SourceToModule
modMap HighlightingInfoBuilder
-> HighlightingInfoBuilder -> HighlightingInfoBuilder
forall a. Semigroup a => a -> a -> a
<>
    Ranges -> Aspects -> HighlightingInfoBuilder
forall a m. IsBasicRangeMap a m => Ranges -> a -> m
H.singleton (Range -> Ranges
rToR Range
rs)
                (Aspects
aspects { definitionSite :: Maybe DefinitionSite
definitionSite = SourceToModule -> Maybe DefinitionSite
mFilePos SourceToModule
modMap })
   else
    Hiliter
forall a. Monoid a => a
mempty
  where
  aspects :: Aspects
aspects       = Bool -> Aspects
asp (Bool -> Aspects) -> Bool -> Aspects
forall a b. (a -> b) -> a -> b
$ Name -> Bool
C.isOperator Name
x
  fileNames :: [Maybe AbsolutePath]
fileNames     = (Name -> Maybe (Maybe AbsolutePath))
-> [Name] -> [Maybe AbsolutePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Position' (Maybe AbsolutePath) -> Maybe AbsolutePath)
-> Maybe (Position' (Maybe AbsolutePath))
-> Maybe (Maybe AbsolutePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Position' (Maybe AbsolutePath) -> Maybe AbsolutePath
forall a. Position' a -> a
P.srcFile (Maybe (Position' (Maybe AbsolutePath))
 -> Maybe (Maybe AbsolutePath))
-> (Name -> Maybe (Position' (Maybe AbsolutePath)))
-> Name
-> Maybe (Maybe AbsolutePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Maybe (Position' (Maybe AbsolutePath))
forall a. Range' a -> Maybe (Position' a)
P.rStart (Range -> Maybe (Position' (Maybe AbsolutePath)))
-> (Name -> Range)
-> Name
-> Maybe (Position' (Maybe AbsolutePath))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Range
forall a. HasRange a => a -> Range
getRange) (Name
x Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
xs)
  frFile :: SourceToModule -> HighlightingInfoBuilder
frFile SourceToModule
modMap = Ranges -> Aspects -> HighlightingInfoBuilder
forall a m. IsBasicRangeMap a m => Ranges -> a -> m
H.singleton (Range -> Ranges
rToR Range
fr) (Aspects
aspects { definitionSite :: Maybe DefinitionSite
definitionSite = DefinitionSite -> DefinitionSite
notHere (DefinitionSite -> DefinitionSite)
-> Maybe DefinitionSite -> Maybe DefinitionSite
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceToModule -> Maybe DefinitionSite
mFilePos SourceToModule
modMap })
  rs :: Range
rs            = [Name] -> Range
forall a. HasRange a => a -> Range
getRange (Name
x Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
xs)

  -- The fixity declaration should not get a symbolic anchor.
  notHere :: DefinitionSite -> DefinitionSite
notHere DefinitionSite
d = DefinitionSite
d { defSiteHere :: Bool
defSiteHere = Bool
False }

  mFilePos
    :: SourceToModule  -- Maps source file paths to module names.
    -> Maybe DefinitionSite
  mFilePos :: SourceToModule -> Maybe DefinitionSite
mFilePos SourceToModule
modMap = do
    Range
r <- Maybe Range
mR
    P.Pn { srcFile :: forall a. Position' a -> a
P.srcFile = Strict.Just AbsolutePath
f, posPos :: forall a. Position' a -> Int32
P.posPos = Int32
p } <- Range -> Maybe (Position' (Maybe AbsolutePath))
forall a. Range' a -> Maybe (Position' a)
P.rStart Range
r
    TopLevelModuleName
mod <- AbsolutePath -> SourceToModule -> Maybe TopLevelModuleName
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AbsolutePath
f SourceToModule
modMap
    -- Andreas, 2017-06-16, Issue #2604: Symbolic anchors.
    -- We drop the file name part from the qualifiers, since
    -- this is contained in the html file name already.
    -- We want to get anchors of the form:
    -- @<a name="TopLevelModule.html#LocalModule.NestedModule.identifier">@
    let qualifiers :: [Name]
qualifiers = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
drop (NonEmpty String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (NonEmpty String -> Int) -> NonEmpty String -> Int
forall a b. (a -> b) -> a -> b
$ TopLevelModuleName -> NonEmpty String
C.moduleNameParts TopLevelModuleName
mod) [Name]
xs
    -- For bound variables, we do not create symbolic anchors.
        local :: Bool
local = Bool -> (Aspect -> Bool) -> Maybe Aspect -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True Aspect -> Bool
isLocalAspect (Maybe Aspect -> Bool) -> Maybe Aspect -> Bool
forall a b. (a -> b) -> a -> b
$ Aspects -> Maybe Aspect
aspect Aspects
aspects
    DefinitionSite -> Maybe DefinitionSite
forall (m :: * -> *) a. Monad m => a -> m a
return (DefinitionSite -> Maybe DefinitionSite)
-> DefinitionSite -> Maybe DefinitionSite
forall a b. (a -> b) -> a -> b
$ DefinitionSite
      { defSiteModule :: TopLevelModuleName
defSiteModule = TopLevelModuleName
mod
      , defSitePos :: Int
defSitePos    = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
p
        -- Is our current position the definition site?
      , defSiteHere :: Bool
defSiteHere   = Range
r Range -> Range -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x
        -- For bound variables etc. we do not create a symbolic anchor name.
        -- Also not for names that include anonymous modules,
        -- otherwise, we do not get unique anchors.
      , defSiteAnchor :: Maybe String
defSiteAnchor = if Bool
local Bool -> Bool -> Bool
|| Name -> Bool
forall a. IsNoName a => a -> Bool
C.isNoName Name
x Bool -> Bool -> Bool
|| (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Name -> Bool
forall a. Underscore a => a -> Bool
Common.isUnderscore [Name]
qualifiers
          then Maybe String
forall a. Maybe a
Nothing
          else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ QName -> String
forall a. Pretty a => a -> String
prettyShow (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ (Name -> QName -> QName) -> QName -> [Name] -> QName
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Name -> QName -> QName
C.Qual (Name -> QName
C.QName Name
x) [Name]
qualifiers
      }

  -- Is the name a bound variable or similar? If in doubt, yes.
  isLocalAspect :: Aspect -> Bool
  isLocalAspect :: Aspect -> Bool
isLocalAspect = \case
    Name (Just NameKind
kind) Bool
_ -> NameKind -> Bool
isLocal NameKind
kind
    Aspect
_ -> Bool
True
  isLocal :: NameKind -> Bool
  isLocal :: NameKind -> Bool
isLocal = \case
    NameKind
Bound         -> Bool
True
    NameKind
Generalizable -> Bool
True
    NameKind
Argument      -> Bool
True
    Constructor{} -> Bool
False
    NameKind
Datatype      -> Bool
False
    NameKind
Field         -> Bool
False
    NameKind
Function      -> Bool
False
    NameKind
Module        -> Bool
False
    NameKind
Postulate     -> Bool
False
    NameKind
Primitive     -> Bool
False
    NameKind
Record        -> Bool
False
    NameKind
Macro         -> Bool
False

-- This was Highlighting.Generate.nameToFileA:
-- | A variant of 'hiliteCName' for qualified abstract names.
hiliteAName
  :: A.QName
     -- ^ The name.
  -> Bool
     -- ^ Should the binding site be included in the file?
  -> (Bool -> Aspects)
     -- ^ Meta information to be associated with the name.
     -- ^ The argument is 'True' iff the name is an operator.
  -> Hiliter
hiliteAName :: QName -> Bool -> (Bool -> Aspects) -> Hiliter
hiliteAName QName
x Bool
include Bool -> Aspects
asp = do
  AbsolutePath
fileName <- (HiliteEnv -> AbsolutePath)
-> ReaderT HiliteEnv Identity AbsolutePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HiliteEnv -> AbsolutePath
hleFileName
  [Name]
-> Name -> Range -> Maybe Range -> (Bool -> Aspects) -> Hiliter
hiliteCName (QName -> [Name]
concreteQualifier QName
x)
              (QName -> Name
concreteBase QName
x)
              (AbsolutePath -> Range
rangeOfFixityDeclaration AbsolutePath
fileName)
              (if Bool
include then Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Maybe Range) -> Range -> Maybe Range
forall a b. (a -> b) -> a -> b
$ QName -> Range
bindingSite QName
x else Maybe Range
forall a. Maybe a
Nothing)
              Bool -> Aspects
asp
    Hiliter -> Hiliter -> Hiliter
forall a. Semigroup a => a -> a -> a
<> (AbsolutePath -> Hiliter
notationFile AbsolutePath
fileName)
  where
  -- TODO: Currently we highlight fixity and syntax declarations by
  -- producing highlighting something like once per occurrence of the
  -- related name(s) in the file of the declaration (and we explicitly
  -- avoid doing this for other files). Perhaps it would be better to
  -- only produce this highlighting once.

  rangeOfFixityDeclaration :: AbsolutePath -> Range
rangeOfFixityDeclaration AbsolutePath
fileName =
    if Range -> Maybe AbsolutePath
P.rangeFile Range
r Maybe AbsolutePath -> Maybe AbsolutePath -> Bool
forall a. Eq a => a -> a -> Bool
== AbsolutePath -> Maybe AbsolutePath
forall a. a -> Maybe a
Strict.Just AbsolutePath
fileName
    then Range
r else Range
forall a. Range' a
noRange
    where
    r :: Range
r = Fixity' -> Range
theNameRange (Fixity' -> Range) -> Fixity' -> Range
forall a b. (a -> b) -> a -> b
$ Name -> Fixity'
A.nameFixity (Name -> Fixity') -> Name -> Fixity'
forall a b. (a -> b) -> a -> b
$ QName -> Name
A.qnameName QName
x

  notationFile :: AbsolutePath -> Hiliter
notationFile AbsolutePath
fileName = HighlightingInfoBuilder -> Hiliter
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HighlightingInfoBuilder -> Hiliter)
-> HighlightingInfoBuilder -> Hiliter
forall a b. (a -> b) -> a -> b
$
    if Range -> Maybe AbsolutePath
P.rangeFile (Notation -> Range
forall a. HasRange a => a -> Range
getRange Notation
notation) Maybe AbsolutePath -> Maybe AbsolutePath -> Bool
forall a. Eq a => a -> a -> Bool
== AbsolutePath -> Maybe AbsolutePath
forall a. a -> Maybe a
Strict.Just AbsolutePath
fileName
    then [HighlightingInfoBuilder] -> HighlightingInfoBuilder
forall a. Monoid a => [a] -> a
mconcat ([HighlightingInfoBuilder] -> HighlightingInfoBuilder)
-> [HighlightingInfoBuilder] -> HighlightingInfoBuilder
forall a b. (a -> b) -> a -> b
$ (GenPart -> HighlightingInfoBuilder)
-> Notation -> [HighlightingInfoBuilder]
forall a b. (a -> b) -> [a] -> [b]
map GenPart -> HighlightingInfoBuilder
genPartFile Notation
notation
    else HighlightingInfoBuilder
forall a. Monoid a => a
mempty
    where
    notation :: Notation
notation = Fixity' -> Notation
theNotation (Fixity' -> Notation) -> Fixity' -> Notation
forall a b. (a -> b) -> a -> b
$ Name -> Fixity'
A.nameFixity (Name -> Fixity') -> Name -> Fixity'
forall a b. (a -> b) -> a -> b
$ QName -> Name
A.qnameName QName
x

    boundAspect :: Aspects
boundAspect = NameKind -> Bool -> Aspects
nameAsp NameKind
Bound Bool
False

    genPartFile :: GenPart -> HighlightingInfoBuilder
genPartFile (BindHole Range
r Ranged Int
i)   = [Ranges] -> Aspects -> HighlightingInfoBuilder
forall a hl.
(IsBasicRangeMap a hl, Monoid hl) =>
[Ranges] -> a -> hl
several [Range -> Ranges
rToR Range
r, Range -> Ranges
rToR (Range -> Ranges) -> Range -> Ranges
forall a b. (a -> b) -> a -> b
$ Ranged Int -> Range
forall a. HasRange a => a -> Range
getRange Ranged Int
i] Aspects
boundAspect
    genPartFile (NormalHole Range
r NamedArg (Ranged Int)
i) = [Ranges] -> Aspects -> HighlightingInfoBuilder
forall a hl.
(IsBasicRangeMap a hl, Monoid hl) =>
[Ranges] -> a -> hl
several [Range -> Ranges
rToR Range
r, Range -> Ranges
rToR (Range -> Ranges) -> Range -> Ranges
forall a b. (a -> b) -> a -> b
$ NamedArg (Ranged Int) -> Range
forall a. HasRange a => a -> Range
getRange NamedArg (Ranged Int)
i] Aspects
boundAspect
    genPartFile WildHole{}       = HighlightingInfoBuilder
forall a. Monoid a => a
mempty
    genPartFile (IdPart RString
x)       = Ranges -> Aspects -> HighlightingInfoBuilder
forall a m. IsBasicRangeMap a m => Ranges -> a -> m
H.singleton (Range -> Ranges
rToR (Range -> Ranges) -> Range -> Ranges
forall a b. (a -> b) -> a -> b
$ RString -> Range
forall a. HasRange a => a -> Range
getRange RString
x) (Bool -> Aspects
asp Bool
False)

-- * Short auxiliary functions.
---------------------------------------------------------------------------

singleAspect :: HasRange a => Aspect -> a -> Hiliter
singleAspect :: forall a. HasRange a => Aspect -> a -> Hiliter
singleAspect Aspect
a a
x = HighlightingInfoBuilder -> Hiliter
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HighlightingInfoBuilder -> Hiliter)
-> HighlightingInfoBuilder -> Hiliter
forall a b. (a -> b) -> a -> b
$ Ranges -> Aspects -> HighlightingInfoBuilder
forall a m. IsBasicRangeMap a m => Ranges -> a -> m
H.singleton (Range -> Ranges
rToR (Range -> Ranges) -> Range -> Ranges
forall a b. (a -> b) -> a -> b
$ a -> Range
forall a. HasRange a => a -> Range
getRange a
x) (Aspects -> HighlightingInfoBuilder)
-> Aspects -> HighlightingInfoBuilder
forall a b. (a -> b) -> a -> b
$ Aspects
parserBased { aspect :: Maybe Aspect
aspect = Aspect -> Maybe Aspect
forall a. a -> Maybe a
Just Aspect
a }

singleOtherAspect :: HasRange a => OtherAspect -> a -> Hiliter
singleOtherAspect :: forall a. HasRange a => OtherAspect -> a -> Hiliter
singleOtherAspect OtherAspect
a a
x = HighlightingInfoBuilder -> Hiliter
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HighlightingInfoBuilder -> Hiliter)
-> HighlightingInfoBuilder -> Hiliter
forall a b. (a -> b) -> a -> b
$ Ranges -> Aspects -> HighlightingInfoBuilder
forall a m. IsBasicRangeMap a m => Ranges -> a -> m
H.singleton (Range -> Ranges
rToR (Range -> Ranges) -> Range -> Ranges
forall a b. (a -> b) -> a -> b
$ a -> Range
forall a. HasRange a => a -> Range
getRange a
x) (Aspects -> HighlightingInfoBuilder)
-> Aspects -> HighlightingInfoBuilder
forall a b. (a -> b) -> a -> b
$ Aspects
parserBased { otherAspects :: Set OtherAspect
otherAspects = OtherAspect -> Set OtherAspect
forall el coll. Singleton el coll => el -> coll
singleton OtherAspect
a }

nameAsp' :: Maybe NameKind -> Bool -> Aspects
nameAsp' :: Maybe NameKind -> Bool -> Aspects
nameAsp' Maybe NameKind
k Bool
isOp = Aspects
parserBased { aspect :: Maybe Aspect
aspect = Aspect -> Maybe Aspect
forall a. a -> Maybe a
Just (Aspect -> Maybe Aspect) -> Aspect -> Maybe Aspect
forall a b. (a -> b) -> a -> b
$ Maybe NameKind -> Bool -> Aspect
Name Maybe NameKind
k Bool
isOp }

nameAsp :: NameKind -> Bool -> Aspects
nameAsp :: NameKind -> Bool -> Aspects
nameAsp = Maybe NameKind -> Bool -> Aspects
nameAsp' (Maybe NameKind -> Bool -> Aspects)
-> (NameKind -> Maybe NameKind) -> NameKind -> Bool -> Aspects
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameKind -> Maybe NameKind
forall a. a -> Maybe a
Just

concreteBase :: A.QName -> C.Name
concreteBase :: QName -> Name
concreteBase = Name -> Name
A.nameConcrete (Name -> Name) -> (QName -> Name) -> QName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
A.qnameName

concreteQualifier :: A.QName -> [C.Name]
concreteQualifier :: QName -> [Name]
concreteQualifier = (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Name
A.nameConcrete ([Name] -> [Name]) -> (QName -> [Name]) -> QName -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Name]
A.mnameToList (ModuleName -> [Name]) -> (QName -> ModuleName) -> QName -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> ModuleName
A.qnameModule

bindingSite :: A.QName -> Range
bindingSite :: QName -> Range
bindingSite = Name -> Range
A.nameBindingSite (Name -> Range) -> (QName -> Name) -> QName -> Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
A.qnameName