{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}

-- ghc-8.8.4 requires -Wno-redundant-constraints
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module GhcTags.Tag
  ( -- * Tag
    TAG_KIND (..)
  , SingTagKind (..)
  , Tag (..)
  , ETag
  , CTag
  , ETagMap
  , CTagMap
    -- ** Tag fields
  , TagName (..)
  , TagFilePath (..)
  , ExCommand (..)
  , TagAddress (..)
  , CTagAddress
  , ETagAddress
  , TagKind (..)
  , CTagKind
  , ETagKind
  , TagDefinition (..)
  , TagFields (..)
  , CTagFields
  , ETagFields
  , TagField (..)
    -- ** Ordering and combining tags
  , compareTags
  , combineTags

  -- * Create 'Tag' from a 'GhcTag'
  , ghcTagToTag
  ) where

import           Control.DeepSeq
import           Data.Function (on)
#if   !MIN_VERSION_GHC(8,10)
import           Data.ByteString (ByteString)
#endif
import qualified Data.ByteString as BS
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Text   (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           System.FilePath.ByteString (RawFilePath)

-- GHC imports
#if   MIN_VERSION_GHC(9,0)
import           GHC.Driver.Session (DynFlags)
#else
import           DynFlags           (DynFlags (pprUserLength))
#endif
#if   MIN_VERSION_GHC(9,0)
import           GHC.Data.FastString (bytesFS)
#elif MIN_VERSION_GHC(8,10)
import           FastString          (bytesFS)
#else
import           FastString          (FastString (fs_bs))
#endif

#if   MIN_VERSION_GHC(9,0)
import           GHC.Types.SrcLoc
                              ( SrcSpan (..)
                              , srcSpanFile
                              , srcSpanStartLine
                              , srcSpanStartCol
                              )
#else
import           SrcLoc       ( SrcSpan (..)
                              , srcSpanFile
                              , srcSpanStartLine
                              , srcSpanStartCol
                              )
#endif

import           GhcTags.Ghc  ( GhcTag (..)
                              , GhcTagKind (..)
                              )
#if   MIN_VERSION_GHC(9,0)
import qualified GHC.Utils.Outputable as Out
#else
import qualified Outputable as Out
#endif

#if   !MIN_VERSION_GHC(8,10)
bytesFS :: FastString -> ByteString
bytesFS = fs_bs
#endif

--
-- Tag
--

-- | Promoted data type used to distinguish 'CTAG's from 'ETAG's.
--
data TAG_KIND = CTAG | ETAG
  deriving Int -> TAG_KIND -> ShowS
[TAG_KIND] -> ShowS
TAG_KIND -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TAG_KIND] -> ShowS
$cshowList :: [TAG_KIND] -> ShowS
show :: TAG_KIND -> String
$cshow :: TAG_KIND -> String
showsPrec :: Int -> TAG_KIND -> ShowS
$cshowsPrec :: Int -> TAG_KIND -> ShowS
Show
  --  `ghc-tags` is using it at term level.


-- | Singletons for promoted types.
--
data SingTagKind (tk :: TAG_KIND) where
    SingCTag :: SingTagKind CTAG
    SingETag :: SingTagKind ETAG


-- | 'ByteString' which encodes a tag name.
--
newtype TagName = TagName { TagName -> Text
getTagName :: Text }
  deriving (TagName -> TagName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagName -> TagName -> Bool
$c/= :: TagName -> TagName -> Bool
== :: TagName -> TagName -> Bool
$c== :: TagName -> TagName -> Bool
Eq, Eq TagName
TagName -> TagName -> Bool
TagName -> TagName -> Ordering
TagName -> TagName -> TagName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TagName -> TagName -> TagName
$cmin :: TagName -> TagName -> TagName
max :: TagName -> TagName -> TagName
$cmax :: TagName -> TagName -> TagName
>= :: TagName -> TagName -> Bool
$c>= :: TagName -> TagName -> Bool
> :: TagName -> TagName -> Bool
$c> :: TagName -> TagName -> Bool
<= :: TagName -> TagName -> Bool
$c<= :: TagName -> TagName -> Bool
< :: TagName -> TagName -> Bool
$c< :: TagName -> TagName -> Bool
compare :: TagName -> TagName -> Ordering
$ccompare :: TagName -> TagName -> Ordering
Ord, Int -> TagName -> ShowS
[TagName] -> ShowS
TagName -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TagName] -> ShowS
$cshowList :: [TagName] -> ShowS
show :: TagName -> String
$cshow :: TagName -> String
showsPrec :: Int -> TagName -> ShowS
$cshowsPrec :: Int -> TagName -> ShowS
Show)

instance NFData TagName where
  rnf :: TagName -> ()
rnf = forall a. NFData a => a -> ()
rnf forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagName -> Text
getTagName

-- | When we parse a `tags` file we can either find no kind or recognize the
-- kind of GhcTagKind or we store the found character kind.  This allows us to
-- preserve information from parsed tags files which were not created by
-- `ghc-tags-plugin'
--
-- * 'TkTerm' - @`@
-- * 'TkFunction' - @λ@
-- * 'TkTypeConstructor' - @Λ@
-- * 'TkDataConstructor' - @c@
-- * 'TkGADTConstructor' - @g@
-- * 'TkRecordField' - @r@
-- * 'TkTypeSynonym' - @≡@
-- * 'TkTypeSignature' - @⊢@
-- * 'TkPatternSynonym' - @p@
-- * 'TkTypeClass' - @C@
-- * 'TkTypeClassMember' - @m@
-- * 'TkTypeClassInstance' - @i@
-- * 'TkTypeClassInstanceMember' - @i@
-- * 'TkTypeFamily' - @f@
-- * 'TkTypeFamilyInstance' - @F@
-- * 'TkDataTypeFamily' - @d@
-- * 'TkDataTypeFamilyInstance' - @D@
-- * 'TkForeignImport' - @I@
-- * 'TkForeignExport' - @E@
--
data TagKind where
    TkModule                  :: TagKind
    TkTerm                    :: TagKind
    TkFunction                :: TagKind
    TkTypeConstructor         :: TagKind
    TkDataConstructor         :: TagKind
    TkGADTConstructor         :: TagKind
    TkRecordField             :: TagKind
    TkTypeSynonym             :: TagKind
    TkTypeSignature           :: TagKind
    TkPatternSynonym          :: TagKind
    TkTypeClass               :: TagKind
    TkTypeClassMember         :: TagKind
    TkTypeClassInstance       :: TagKind
    TkTypeClassInstanceMember :: TagKind
    TkTypeFamily              :: TagKind
    TkTypeFamilyInstance      :: TagKind
    TkDataTypeFamily          :: TagKind
    TkDataTypeFamilyInstance  :: TagKind
    TkForeignImport           :: TagKind
    TkForeignExport           :: TagKind
    CharKind                  :: !Char -> TagKind
    NoKind                    :: TagKind

type CTagKind = TagKind
{-# DEPRECATED CTagKind "Use TagKind" #-}
type ETagKind = TagKind
{-# DEPRECATED ETagKind "Use TagKind" #-}

deriving instance Eq   TagKind
deriving instance Ord  TagKind
deriving instance Show TagKind
instance NFData TagKind where
  rnf :: TagKind -> ()
rnf TagKind
x = TagKind
x seq :: forall a b. a -> b -> b
`seq` ()


newtype ExCommand = ExCommand { ExCommand -> Text
getExCommand :: Text }
  deriving (ExCommand -> ExCommand -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExCommand -> ExCommand -> Bool
$c/= :: ExCommand -> ExCommand -> Bool
== :: ExCommand -> ExCommand -> Bool
$c== :: ExCommand -> ExCommand -> Bool
Eq, Eq ExCommand
ExCommand -> ExCommand -> Bool
ExCommand -> ExCommand -> Ordering
ExCommand -> ExCommand -> ExCommand
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ExCommand -> ExCommand -> ExCommand
$cmin :: ExCommand -> ExCommand -> ExCommand
max :: ExCommand -> ExCommand -> ExCommand
$cmax :: ExCommand -> ExCommand -> ExCommand
>= :: ExCommand -> ExCommand -> Bool
$c>= :: ExCommand -> ExCommand -> Bool
> :: ExCommand -> ExCommand -> Bool
$c> :: ExCommand -> ExCommand -> Bool
<= :: ExCommand -> ExCommand -> Bool
$c<= :: ExCommand -> ExCommand -> Bool
< :: ExCommand -> ExCommand -> Bool
$c< :: ExCommand -> ExCommand -> Bool
compare :: ExCommand -> ExCommand -> Ordering
$ccompare :: ExCommand -> ExCommand -> Ordering
Ord, Int -> ExCommand -> ShowS
[ExCommand] -> ShowS
ExCommand -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExCommand] -> ShowS
$cshowList :: [ExCommand] -> ShowS
show :: ExCommand -> String
$cshow :: ExCommand -> String
showsPrec :: Int -> ExCommand -> ShowS
$cshowsPrec :: Int -> ExCommand -> ShowS
Show)


-- | Tag address, either from a parsed file or from Haskell's AST>
--
data TagAddress (tk :: TAG_KIND) where
      -- | Precise address: line and column.  This is what we infer from @GHC@
      -- AST.
      --
      -- The two arguments are line number and either column number or offset
      -- from the beginning of the file.
      --
      TagLineCol :: !Int -> !Int -> TagAddress tk

      -- | ctags can only use range ex-commands as an address (or a sequence of
      -- them separated by `;`). We parse line number specifically, since they
      -- are useful for ordering tags.
      --
      TagLine :: !Int -> TagAddress tk

      -- | A tag address can be just an ex command.
      --
      TagCommand :: !ExCommand -> TagAddress CTAG

      -- | etags file format allows to discard the address
      --
      NoAddress :: TagAddress ETAG


-- | 'CTag' addresses.
--
type CTagAddress = TagAddress CTAG

-- | 'ETag' addresses.
--
type ETagAddress = TagAddress ETAG


deriving instance Eq   (TagAddress tk)
deriving instance Ord  (TagAddress tk)
deriving instance Show (TagAddress tk)
instance NFData (TagAddress tt) where
  rnf :: TagAddress tt -> ()
rnf TagAddress tt
x = TagAddress tt
x seq :: forall a b. a -> b -> b
`seq` ()


-- | Emacs tags specific field.
--
data TagDefinition (tk :: TAG_KIND) where
      TagDefinition   :: !Text -> TagDefinition ETAG
      NoTagDefinition :: TagDefinition tk

deriving instance Show (TagDefinition tk)
deriving instance Eq   (TagDefinition tk)
instance NFData (TagDefinition tt) where
  rnf :: TagDefinition tt -> ()
rnf TagDefinition tt
x = TagDefinition tt
x seq :: forall a b. a -> b -> b
`seq` ()

-- | Unit of data associated with a tag.  Vim natively supports `file:` and
-- `kind:` tags but it can display any other tags too.
--
data TagField = TagField {
      TagField -> Text
fieldName  :: Text,
      TagField -> Text
fieldValue :: Text
    }
  deriving (TagField -> TagField -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagField -> TagField -> Bool
$c/= :: TagField -> TagField -> Bool
== :: TagField -> TagField -> Bool
$c== :: TagField -> TagField -> Bool
Eq, Eq TagField
TagField -> TagField -> Bool
TagField -> TagField -> Ordering
TagField -> TagField -> TagField
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TagField -> TagField -> TagField
$cmin :: TagField -> TagField -> TagField
max :: TagField -> TagField -> TagField
$cmax :: TagField -> TagField -> TagField
>= :: TagField -> TagField -> Bool
$c>= :: TagField -> TagField -> Bool
> :: TagField -> TagField -> Bool
$c> :: TagField -> TagField -> Bool
<= :: TagField -> TagField -> Bool
$c<= :: TagField -> TagField -> Bool
< :: TagField -> TagField -> Bool
$c< :: TagField -> TagField -> Bool
compare :: TagField -> TagField -> Ordering
$ccompare :: TagField -> TagField -> Ordering
Ord, Int -> TagField -> ShowS
[TagField] -> ShowS
TagField -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TagField] -> ShowS
$cshowList :: [TagField] -> ShowS
show :: TagField -> String
$cshow :: TagField -> String
showsPrec :: Int -> TagField -> ShowS
$cshowsPrec :: Int -> TagField -> ShowS
Show)

instance NFData TagField where
    rnf :: TagField -> ()
rnf TagField { Text
fieldName :: Text
fieldName :: TagField -> Text
fieldName, Text
fieldValue :: Text
fieldValue :: TagField -> Text
fieldValue } =
         forall a. NFData a => a -> ()
rnf Text
fieldName seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Text
fieldValue


-- | File field; tags which contain 'fileField' are called static (aka static
-- in @C@), such tags are only visible in the current file)
--
fileField :: TagField
fileField :: TagField
fileField = TagField { fieldName :: Text
fieldName = Text
"file", fieldValue :: Text
fieldValue = Text
"" }


-- | Ctags specific list of 'TagField's.
--
data TagFields (tk :: TAG_KIND) where
    NoTagFields :: TagFields ETAG

    TagFields   :: ![TagField]
                -> TagFields CTAG

deriving instance Show (TagFields tk)
deriving instance Eq   (TagFields tk)

-- | Left biased semigroup.
--
instance Semigroup (TagFields tk) where
    TagFields tk
NoTagFields  <> :: TagFields tk -> TagFields tk -> TagFields tk
<> TagFields tk
NoTagFields  = TagFields 'ETAG
NoTagFields
    TagFields [TagField]
as <> TagFields [TagField]
bs = [TagField] -> TagFields 'CTAG
TagFields
                                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> TagField
TagField)
                                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
                                 forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TagField -> Text
fieldName TagField
f, TagField -> Text
fieldValue TagField
f) | TagField
f <- [TagField]
as]
                                   forall a. Semigroup a => a -> a -> a
<>
                                   forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TagField -> Text
fieldName TagField
f, TagField -> Text
fieldValue TagField
f) | TagField
f <- [TagField]
bs]

instance Monoid (TagFields CTAG) where
    mempty :: TagFields 'CTAG
mempty = [TagField] -> TagFields 'CTAG
TagFields forall a. Monoid a => a
mempty
instance Monoid (TagFields ETAG) where
    mempty :: TagFields 'ETAG
mempty = TagFields 'ETAG
NoTagFields
instance NFData (TagFields tk) where
    rnf :: TagFields tk -> ()
rnf TagFields tk
NoTagFields    = ()
    rnf (TagFields [TagField]
as) = forall a. NFData a => a -> ()
rnf [TagField]
as

type CTagFields = TagFields CTAG
type ETagFields = TagFields ETAG

newtype TagFilePath = TagFilePath { TagFilePath -> Text
getRawFilePath :: Text }
  deriving (Eq TagFilePath
TagFilePath -> TagFilePath -> Bool
TagFilePath -> TagFilePath -> Ordering
TagFilePath -> TagFilePath -> TagFilePath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TagFilePath -> TagFilePath -> TagFilePath
$cmin :: TagFilePath -> TagFilePath -> TagFilePath
max :: TagFilePath -> TagFilePath -> TagFilePath
$cmax :: TagFilePath -> TagFilePath -> TagFilePath
>= :: TagFilePath -> TagFilePath -> Bool
$c>= :: TagFilePath -> TagFilePath -> Bool
> :: TagFilePath -> TagFilePath -> Bool
$c> :: TagFilePath -> TagFilePath -> Bool
<= :: TagFilePath -> TagFilePath -> Bool
$c<= :: TagFilePath -> TagFilePath -> Bool
< :: TagFilePath -> TagFilePath -> Bool
$c< :: TagFilePath -> TagFilePath -> Bool
compare :: TagFilePath -> TagFilePath -> Ordering
$ccompare :: TagFilePath -> TagFilePath -> Ordering
Ord, Int -> TagFilePath -> ShowS
[TagFilePath] -> ShowS
TagFilePath -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TagFilePath] -> ShowS
$cshowList :: [TagFilePath] -> ShowS
show :: TagFilePath -> String
$cshow :: TagFilePath -> String
showsPrec :: Int -> TagFilePath -> ShowS
$cshowsPrec :: Int -> TagFilePath -> ShowS
Show)

instance Eq TagFilePath where
    (TagFilePath Text
a) == :: TagFilePath -> TagFilePath -> Bool
== (TagFilePath Text
b) = Text
a forall a. Eq a => a -> a -> Bool
== Text
b

instance NFData TagFilePath where
  rnf :: TagFilePath -> ()
rnf = forall a. NFData a => a -> ()
rnf forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagFilePath -> Text
getRawFilePath

-- | Tag record.  For either ctags or etags formats.  It is either filled with
-- information parsed from a tags file or from *GHC* ast.
--
data Tag (tk :: TAG_KIND) = Tag
  { forall (tk :: TAG_KIND). Tag tk -> TagName
tagName       :: !TagName
    -- ^ name of the tag
  , forall (tk :: TAG_KIND). Tag tk -> TagKind
tagKind       :: !TagKind
    -- ^ ctags specific field, which classifies tags
  , forall (tk :: TAG_KIND). Tag tk -> TagFilePath
tagFilePath   :: !TagFilePath
    -- ^ source file path; it might not be normalised.
  , forall (tk :: TAG_KIND). Tag tk -> TagAddress tk
tagAddr       :: !(TagAddress tk)
    -- ^ address in source file
  , forall (tk :: TAG_KIND). Tag tk -> TagDefinition tk
tagDefinition :: !(TagDefinition tk)
    -- ^ etags specific field; only tags read from emacs tags file contain this
    -- field.
  , forall (tk :: TAG_KIND). Tag tk -> TagFields tk
tagFields     :: !(TagFields tk)
    -- ^ ctags specific field
  }
  deriving Int -> Tag tk -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (tk :: TAG_KIND). Int -> Tag tk -> ShowS
forall (tk :: TAG_KIND). [Tag tk] -> ShowS
forall (tk :: TAG_KIND). Tag tk -> String
showList :: [Tag tk] -> ShowS
$cshowList :: forall (tk :: TAG_KIND). [Tag tk] -> ShowS
show :: Tag tk -> String
$cshow :: forall (tk :: TAG_KIND). Tag tk -> String
showsPrec :: Int -> Tag tk -> ShowS
$cshowsPrec :: forall (tk :: TAG_KIND). Int -> Tag tk -> ShowS
Show

instance Eq (Tag tk) where
    Tag tk
t0 == :: Tag tk -> Tag tk -> Bool
== Tag tk
t1 = forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Eq a => a -> a -> Bool
(==) forall (tk :: TAG_KIND). Tag tk -> TagName
tagName Tag tk
t0 Tag tk
t1
            Bool -> Bool -> Bool
&& forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Eq a => a -> a -> Bool
(==) forall (tk :: TAG_KIND). Tag tk -> TagKind
tagKind Tag tk
t0 Tag tk
t1
            Bool -> Bool -> Bool
&& forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Eq a => a -> a -> Bool
(==) forall (tk :: TAG_KIND). Tag tk -> TagFilePath
tagFilePath Tag tk
t0 Tag tk
t1
            Bool -> Bool -> Bool
&& forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Eq a => a -> a -> Bool
(==) forall (tk :: TAG_KIND). Tag tk -> TagAddress tk
tagAddr Tag tk
t0 Tag tk
t1
            Bool -> Bool -> Bool
&& forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Eq a => a -> a -> Bool
(==) forall (tk :: TAG_KIND). Tag tk -> TagDefinition tk
tagDefinition Tag tk
t0 Tag tk
t1
            Bool -> Bool -> Bool
&& forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Eq a => a -> a -> Bool
(==) forall (tk :: TAG_KIND). Tag tk -> TagFields tk
tagFields Tag tk
t0 Tag tk
t1

instance NFData (Tag tt) where
  rnf :: Tag tt -> ()
rnf Tag {TagFilePath
TagFields tt
TagDefinition tt
TagAddress tt
TagKind
TagName
tagFields :: TagFields tt
tagDefinition :: TagDefinition tt
tagAddr :: TagAddress tt
tagFilePath :: TagFilePath
tagKind :: TagKind
tagName :: TagName
tagFields :: forall (tk :: TAG_KIND). Tag tk -> TagFields tk
tagDefinition :: forall (tk :: TAG_KIND). Tag tk -> TagDefinition tk
tagAddr :: forall (tk :: TAG_KIND). Tag tk -> TagAddress tk
tagFilePath :: forall (tk :: TAG_KIND). Tag tk -> TagFilePath
tagKind :: forall (tk :: TAG_KIND). Tag tk -> TagKind
tagName :: forall (tk :: TAG_KIND). Tag tk -> TagName
..} = forall a. NFData a => a -> ()
rnf TagName
tagName
           seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf TagKind
tagKind
           seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf TagAddress tt
tagAddr
           seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf TagDefinition tt
tagDefinition
           seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf TagFields tt
tagFields


type CTag = Tag CTAG
type ETag = Tag ETAG

type TagMap tt = Map TagFilePath [Tag tt]
type CTagMap = TagMap CTAG
type ETagMap = TagMap ETAG


-- | Total order relation on 'Tag' elements.
--
-- It sorts type classes / type families ('TkTypeClass', 'TkTypeFamily',
-- 'TkDataTypeFamily')  before instances ('TkTypeClassInstance',
-- 'TkTypeFamilyInstance', 'TkDataTypeFamilyInstance'); but also (as a side
-- effect of keeping transitivity property) it will put type classes and their
-- instances before other kinds.
--
-- It satisfies the following properties:
--
-- * anti-symmetry
-- * reflexivity
-- * transitivity
-- * partial consistency with 'Eq' instance:
--
--   prop> a == b => compareTags a b == EQ
--
compareTags :: forall (tk :: TAG_KIND).
               Ord (TagAddress tk)
            => Tag tk -> Tag tk -> Ordering
compareTags :: forall (tk :: TAG_KIND).
Ord (TagAddress tk) =>
Tag tk -> Tag tk -> Ordering
compareTags Tag tk
t0 Tag tk
t1 = forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Ord a => a -> a -> Ordering
compare forall (tk :: TAG_KIND). Tag tk -> TagName
tagName Tag tk
t0 Tag tk
t1
                    -- sort type classes / type families before their instances,
                    -- and take precedence over a file where they are defined.
                    --
                    -- This will also sort type classes and instances before any
                    -- other terms.
                 forall a. Semigroup a => a -> a -> a
<> forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Ord a => a -> a -> Ordering
compare Tag tk -> Maybe TagKind
getTkClass  Tag tk
t0 Tag tk
t1
                 forall a. Semigroup a => a -> a -> a
<> forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Ord a => a -> a -> Ordering
compare forall (tk :: TAG_KIND). Tag tk -> TagFilePath
tagFilePath Tag tk
t0 Tag tk
t1
                 forall a. Semigroup a => a -> a -> a
<> forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Ord a => a -> a -> Ordering
compare forall (tk :: TAG_KIND). Tag tk -> TagAddress tk
tagAddr     Tag tk
t0 Tag tk
t1
                 forall a. Semigroup a => a -> a -> a
<> forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Ord a => a -> a -> Ordering
compare forall (tk :: TAG_KIND). Tag tk -> TagKind
tagKind     Tag tk
t0 Tag tk
t1

    where
      getTkClass :: Tag tk -> Maybe TagKind
      getTkClass :: Tag tk -> Maybe TagKind
getTkClass Tag tk
t = case forall (tk :: TAG_KIND). Tag tk -> TagKind
tagKind Tag tk
t of
        TagKind
TkTypeClass              -> forall a. a -> Maybe a
Just TagKind
TkTypeClass
        TagKind
TkTypeClassInstance      -> forall a. a -> Maybe a
Just TagKind
TkTypeClassInstance
        TagKind
TkTypeFamily             -> forall a. a -> Maybe a
Just TagKind
TkTypeFamily
        TagKind
TkTypeFamilyInstance     -> forall a. a -> Maybe a
Just TagKind
TkTypeFamilyInstance
        TagKind
TkDataTypeFamily         -> forall a. a -> Maybe a
Just TagKind
TkDataTypeFamily
        TagKind
TkDataTypeFamilyInstance -> forall a. a -> Maybe a
Just TagKind
TkDataTypeFamilyInstance
        TagKind
_                        -> forall a. Maybe a
Nothing



-- | Combine tags from a single /GHC/ module with tags read from a tags file
-- with respect to the given ordering function, e.g. 'GhcTags.CTags.orderTags'
-- or 'GhcTags.ETags.orderTags'.
--
-- This is performance crtitical function.  Tags from the first list are
-- assumeed to be from the same file.
--
-- complexity: /O(max n m)/
--
combineTags :: (Tag tk -> Tag tk -> Ordering)
            -> RawFilePath
            -> [Tag tk] -> [Tag tk] -> [Tag tk]
combineTags :: forall (tk :: TAG_KIND).
(Tag tk -> Tag tk -> Ordering)
-> RawFilePath -> [Tag tk] -> [Tag tk] -> [Tag tk]
combineTags Tag tk -> Tag tk -> Ordering
compareFn RawFilePath
modPath = [Tag tk] -> [Tag tk] -> [Tag tk]
go
  where
    go :: [Tag tk] -> [Tag tk] -> [Tag tk]
go as :: [Tag tk]
as@(Tag tk
a : [Tag tk]
as') bs :: [Tag tk]
bs@(Tag tk
b : [Tag tk]
bs')
      | RawFilePath
modPath RawFilePath -> RawFilePath -> Bool
`BS.isSuffixOf` Text -> RawFilePath
Text.encodeUtf8 (TagFilePath -> Text
getRawFilePath (forall (tk :: TAG_KIND). Tag tk -> TagFilePath
tagFilePath Tag tk
b))
      = [Tag tk] -> [Tag tk] -> [Tag tk]
go [Tag tk]
as [Tag tk]
bs'
      | Bool
otherwise = case Tag tk
a Tag tk -> Tag tk -> Ordering
`compareFn` Tag tk
b of
          Ordering
LT -> Tag tk
a forall a. a -> [a] -> [a]
: [Tag tk] -> [Tag tk] -> [Tag tk]
go [Tag tk]
as' [Tag tk]
bs
          Ordering
EQ -> Tag tk
a forall a. a -> [a] -> [a]
: [Tag tk] -> [Tag tk] -> [Tag tk]
go [Tag tk]
as' [Tag tk]
bs'
          Ordering
GT -> Tag tk
b forall a. a -> [a] -> [a]
: [Tag tk] -> [Tag tk] -> [Tag tk]
go [Tag tk]
as  [Tag tk]
bs'
    go [] [Tag tk]
bs = forall a. (a -> Bool) -> [a] -> [a]
filter (\Tag tk
b -> Bool -> Bool
not (RawFilePath
modPath RawFilePath -> RawFilePath -> Bool
`BS.isSuffixOf` Text -> RawFilePath
Text.encodeUtf8 (TagFilePath -> Text
getRawFilePath (forall (tk :: TAG_KIND). Tag tk -> TagFilePath
tagFilePath Tag tk
b)))) [Tag tk]
bs
    go [Tag tk]
as [] = [Tag tk]
as
    {-# INLINE go #-}


-- | A left biased semigroup for 'Tag', which allows to merge 'TagFields' using
-- their monoid instance.
--
instance Semigroup (Tag tk) where
    Tag tk
a <> :: Tag tk -> Tag tk -> Tag tk
<> Tag tk
b = Tag tk
a { tagFields :: TagFields tk
tagFields = forall (tk :: TAG_KIND). Tag tk -> TagFields tk
tagFields Tag tk
a forall a. Semigroup a => a -> a -> a
<> forall (tk :: TAG_KIND). Tag tk -> TagFields tk
tagFields Tag tk
b }

--
--  GHC interface
--

-- | Create a 'Tag' from 'GhcTag'.
--
ghcTagToTag :: SingTagKind tk -> DynFlags
            -> GhcTag -> Maybe (Tag tk)
#if   MIN_VERSION_GHC(9,2)
ghcTagToTag :: forall (tk :: TAG_KIND).
SingTagKind tk -> DynFlags -> GhcTag -> Maybe (Tag tk)
ghcTagToTag SingTagKind tk
sing DynFlags
_dynFlags GhcTag { SrcSpan
gtSrcSpan :: GhcTag -> SrcSpan
gtSrcSpan :: SrcSpan
gtSrcSpan, RawFilePath
gtTag :: GhcTag -> RawFilePath
gtTag :: RawFilePath
gtTag, GhcTagKind
gtKind :: GhcTag -> GhcTagKind
gtKind :: GhcTagKind
gtKind, Bool
gtIsExported :: GhcTag -> Bool
gtIsExported :: Bool
gtIsExported, Maybe String
gtFFI :: GhcTag -> Maybe String
gtFFI :: Maybe String
gtFFI } =
#else
ghcTagToTag sing  dynFlags GhcTag { gtSrcSpan, gtTag, gtKind, gtIsExported, gtFFI } =
#endif
    case SrcSpan
gtSrcSpan of
      UnhelpfulSpan {} -> forall a. Maybe a
Nothing
#if   MIN_VERSION_GHC(9,0)
      RealSrcSpan RealSrcSpan
realSrcSpan Maybe BufSpan
_ ->
#else
      RealSrcSpan realSrcSpan ->
#endif
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Tag
          { tagName :: TagName
tagName       = Text -> TagName
TagName (RawFilePath -> Text
Text.decodeUtf8 RawFilePath
gtTag)
          , tagFilePath :: TagFilePath
tagFilePath   = Text -> TagFilePath
TagFilePath
                          forall a b. (a -> b) -> a -> b
$ RawFilePath -> Text
Text.decodeUtf8
                          forall a b. (a -> b) -> a -> b
$ FastString -> RawFilePath
bytesFS
                          forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
realSrcSpan

          , tagAddr :: TagAddress tk
tagAddr       =
              case SingTagKind tk
sing of
                SingTagKind tk
SingETag -> forall (tk :: TAG_KIND). Int -> TagAddress tk
TagLine    (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
realSrcSpan)
                SingTagKind tk
SingCTag -> forall (tk :: TAG_KIND). Int -> Int -> TagAddress tk
TagLineCol (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
realSrcSpan)
                                       (RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
realSrcSpan)

          , tagKind :: TagKind
tagKind       = GhcTagKind -> TagKind
fromGhcTagKind GhcTagKind
gtKind
          , tagDefinition :: TagDefinition tk
tagDefinition = forall (tk :: TAG_KIND). TagDefinition tk
NoTagDefinition

          , tagFields :: TagFields tk
tagFields     = (    forall (tk :: TAG_KIND). SingTagKind tk -> TagFields tk
staticField
                              forall a. Semigroup a => a -> a -> a
<> forall (tk :: TAG_KIND). SingTagKind tk -> TagFields tk
ffiField
                              forall a. Semigroup a => a -> a -> a
<> forall (tk :: TAG_KIND). SingTagKind tk -> TagFields tk
kindField
                            ) SingTagKind tk
sing
          }

  where
    fromGhcTagKind :: GhcTagKind -> TagKind
    fromGhcTagKind :: GhcTagKind -> TagKind
fromGhcTagKind = \case
      GhcTagKind
GtkModule                     -> TagKind
TkModule
      GhcTagKind
GtkTerm                       -> TagKind
TkTerm
      GhcTagKind
GtkFunction                   -> TagKind
TkFunction
      GtkTypeConstructor {}         -> TagKind
TkTypeConstructor
      GtkDataConstructor {}         -> TagKind
TkDataConstructor
      GtkGADTConstructor {}         -> TagKind
TkGADTConstructor
      GhcTagKind
GtkRecordField                -> TagKind
TkRecordField
      GtkTypeSynonym {}             -> TagKind
TkTypeSynonym
      GtkTypeSignature {}           -> TagKind
TkTypeSignature
      GtkTypeKindSignature {}       -> TagKind
TkTypeSignature
      GhcTagKind
GtkPatternSynonym             -> TagKind
TkPatternSynonym
      GhcTagKind
GtkTypeClass                  -> TagKind
TkTypeClass
      GtkTypeClassMember {}         -> TagKind
TkTypeClassMember
      GtkTypeClassInstance {}       -> TagKind
TkTypeClassInstance
      GtkTypeClassInstanceMember {} -> TagKind
TkTypeClassInstanceMember
      GtkTypeFamily {}              -> TagKind
TkTypeFamily
      GtkTypeFamilyInstance {}      -> TagKind
TkTypeFamilyInstance
      GtkDataTypeFamily {}          -> TagKind
TkDataTypeFamily
      GtkDataTypeFamilyInstance {}  -> TagKind
TkDataTypeFamilyInstance
      GhcTagKind
GtkForeignImport              -> TagKind
TkForeignImport
      GhcTagKind
GtkForeignExport              -> TagKind
TkForeignExport

    -- static field (whether term is exported or not)
    staticField :: SingTagKind tk -> TagFields tk
    staticField :: forall (tk :: TAG_KIND). SingTagKind tk -> TagFields tk
staticField = \case
      SingTagKind tk
SingETag -> TagFields 'ETAG
NoTagFields
      SingTagKind tk
SingCTag ->
        [TagField] -> TagFields 'CTAG
TagFields forall a b. (a -> b) -> a -> b
$
          if Bool
gtIsExported
            then forall a. Monoid a => a
mempty
            else [TagField
fileField]

    -- ffi field
    ffiField :: SingTagKind tk -> TagFields tk
    ffiField :: forall (tk :: TAG_KIND). SingTagKind tk -> TagFields tk
ffiField = \case
      SingTagKind tk
SingETag -> TagFields 'ETAG
NoTagFields
      SingTagKind tk
SingCTag ->
        [TagField] -> TagFields 'CTAG
TagFields forall a b. (a -> b) -> a -> b
$
          case Maybe String
gtFFI of
            Maybe String
Nothing  -> forall a. Monoid a => a
mempty
            Just String
ffi -> [Text -> Text -> TagField
TagField Text
"ffi" (String -> Text
Text.pack String
ffi)]


    -- 'TagFields' from 'GhcTagKind'
    kindField :: SingTagKind tk -> TagFields tk
    kindField :: forall (tk :: TAG_KIND). SingTagKind tk -> TagFields tk
kindField = \case
      SingTagKind tk
SingETag -> TagFields 'ETAG
NoTagFields
      SingTagKind tk
SingCTag ->
        case GhcTagKind
gtKind of
          GtkTypeClassInstance HsType GhcPs
hsType ->
            forall p. Outputable p => Text -> p -> TagFields 'CTAG
mkField Text
"instance" HsType GhcPs
hsType

          GtkTypeClassInstanceMember HsType GhcPs
hsType ->
            forall p. Outputable p => Text -> p -> TagFields 'CTAG
mkField Text
"instance" HsType GhcPs
hsType

          GtkTypeFamily (Just ([GhcPsHsTyVarBndr]
hsTyVars, Either (HsType GhcPs) GhcPsHsTyVarBndr
hsKind)) ->
            [TagField] -> TagFields 'CTAG
TagFields
              [ TagField
                 { fieldName :: Text
fieldName  = Text
kindFieldName
                 , fieldValue :: Text
fieldValue = Text -> [Text] -> Text
Text.intercalate Text
" -> " (forall p. Outputable p => p -> Text
render forall a b. (a -> b) -> [a] -> [b]
`map` [GhcPsHsTyVarBndr]
hsTyVars)
                             forall a. Semigroup a => a -> a -> a
<> case [GhcPsHsTyVarBndr]
hsTyVars of
                                  []      ->           forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall p. Outputable p => p -> Text
render forall p. Outputable p => p -> Text
render Either (HsType GhcPs) GhcPsHsTyVarBndr
hsKind
                                  (GhcPsHsTyVarBndr
_ : [GhcPsHsTyVarBndr]
_) -> Text
" -> " forall a. Semigroup a => a -> a -> a
<> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall p. Outputable p => p -> Text
render forall p. Outputable p => p -> Text
render Either (HsType GhcPs) GhcPsHsTyVarBndr
hsKind

                 }
              ]
          GtkTypeFamilyInstance Maybe (TyFamInstDecl GhcPs)
decl ->
            [TagField] -> TagFields 'CTAG
TagFields
              [ TagField
                  { fieldName :: Text
fieldName = Text
typeFieldName
                  , fieldValue :: Text
fieldValue = forall p. Outputable p => p -> Text
render Maybe (TyFamInstDecl GhcPs)
decl
                  }
              ]

          GtkDataTypeFamily (Just ([GhcPsHsTyVarBndr], Either (HsType GhcPs) GhcPsHsTyVarBndr)
hsKind) ->
            forall p. Outputable p => Text -> p -> TagFields 'CTAG
mkField Text
kindFieldName ([GhcPsHsTyVarBndr], Either (HsType GhcPs) GhcPsHsTyVarBndr)
hsKind

          GtkDataTypeFamilyInstance (Just HsType GhcPs
hsKind) ->
            forall p. Outputable p => Text -> p -> TagFields 'CTAG
mkField Text
kindFieldName HsType GhcPs
hsKind

          GtkTypeSignature HsWildCardBndrs GhcPs (LHsSigType GhcPs)
hsSigWcType ->
            forall p. Outputable p => Text -> p -> TagFields 'CTAG
mkField Text
typeFieldName HsWildCardBndrs GhcPs (LHsSigType GhcPs)
hsSigWcType

          GtkTypeSynonym HsType GhcPs
hsType ->
            forall p. Outputable p => Text -> p -> TagFields 'CTAG
mkField Text
typeFieldName HsType GhcPs
hsType

          GtkTypeConstructor (Just HsType GhcPs
hsKind) ->
            forall p. Outputable p => Text -> p -> TagFields 'CTAG
mkField Text
kindFieldName HsType GhcPs
hsKind

          GtkDataConstructor ConDecl GhcPs
decl ->
            [TagField] -> TagFields 'CTAG
TagFields
              [TagField
                { fieldName :: Text
fieldName  = Text
termFieldName
                , fieldValue :: Text
fieldValue = forall p. Outputable p => p -> Text
render ConDecl GhcPs
decl
                }]

          GtkGADTConstructor ConDecl GhcPs
decl ->
            [TagField] -> TagFields 'CTAG
TagFields
              [TagField
                { fieldName :: Text
fieldName  = Text
termFieldName
                , fieldValue :: Text
fieldValue = forall p. Outputable p => p -> Text
render ConDecl GhcPs
decl
                }]

          GtkTypeClassMember HsType GhcPs
hsType ->
            forall p. Outputable p => Text -> p -> TagFields 'CTAG
mkField Text
typeFieldName HsType GhcPs
hsType

          GhcTagKind
_ -> forall a. Monoid a => a
mempty


    kindFieldName, typeFieldName, termFieldName :: Text
    kindFieldName :: Text
kindFieldName = Text
"Kind" -- "kind" is reserved
    typeFieldName :: Text
typeFieldName = Text
"type"
    termFieldName :: Text
termFieldName = Text
"term"

    --
    -- fields
    --

    mkField :: Out.Outputable p => Text -> p -> TagFields CTAG
    mkField :: forall p. Outputable p => Text -> p -> TagFields 'CTAG
mkField Text
fieldName  p
p =
      [TagField] -> TagFields 'CTAG
TagFields
        [ TagField
            { Text
fieldName :: Text
fieldName :: Text
fieldName
            , fieldValue :: Text
fieldValue = forall p. Outputable p => p -> Text
render p
p
            }]

    render :: Out.Outputable p => p -> Text
    render :: forall p. Outputable p => p -> Text
render p
hsType =
        Text -> [Text] -> Text
Text.intercalate Text
" " -- remove all line breaks, tabs and multiple spaces
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.words
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
#if   MIN_VERSION_GHC(9,2)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> SDoc -> String
Out.renderWithContext
          SDocContext
Out.defaultSDocContext { sdocStyle :: PprStyle
Out.sdocStyle = PrintUnqualified -> PprStyle
Out.mkErrStyle PrintUnqualified
Out.neverQualify }
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
Out.ppr
      forall a b. (a -> b) -> a -> b
$ p
hsType
#elif MIN_VERSION_GHC(9,0)
      $ Out.renderWithStyle
          (Out.initSDocContext
            dynFlags
            (Out.setStyleColoured False
              $ Out.mkErrStyle Out.neverQualify))
          (Out.ppr hsType)
          
#else
      $ Out.renderWithStyle
          (dynFlags { pprUserLength = 1 })
          (Out.ppr hsType)
          (Out.setStyleColoured False
            $ Out.mkErrStyle dynFlags Out.neverQualify)
#endif