{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
module GhcTags.Tag
(
TAG_KIND (..)
, SingTagKind (..)
, Tag (..)
, ETag
, CTag
, TagName (..)
, TagFilePath (..)
, ExCommand (..)
, TagAddress (..)
, CTagAddress
, ETagAddress
, TagKind (..)
, CTagKind
, ETagKind
, TagDefinition (..)
, TagFields (..)
, CTagFields
, ETagFields
, TagField (..)
, compareTags
, combineTags
, ghcTagToTag
) where
import Data.Function (on)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import System.FilePath.ByteString (RawFilePath)
import DynFlags ( DynFlags (pprUserLength) )
import FastString ( FastString (..) )
import SrcLoc ( SrcSpan (..)
, srcSpanFile
, srcSpanStartLine
, srcSpanStartCol
)
import GhcTags.Ghc ( GhcTag (..)
, GhcTagKind (..)
)
import qualified Outputable as Out
data TAG_KIND = CTAG | ETAG
data SingTagKind (tk :: TAG_KIND) where
SingCTag :: SingTagKind CTAG
SingETag :: SingTagKind ETAG
newtype TagName = TagName { getTagName :: Text }
deriving (Eq, Ord, Show)
data TagKind (tk :: TAG_KIND) where
TkTerm :: TagKind CTAG
TkFunction :: TagKind CTAG
TkTypeConstructor :: TagKind CTAG
TkDataConstructor :: TagKind CTAG
TkGADTConstructor :: TagKind CTAG
TkRecordField :: TagKind CTAG
TkTypeSynonym :: TagKind CTAG
TkTypeSignature :: TagKind CTAG
TkPatternSynonym :: TagKind CTAG
TkTypeClass :: TagKind CTAG
TkTypeClassMember :: TagKind CTAG
TkTypeClassInstance :: TagKind CTAG
TkTypeFamily :: TagKind CTAG
TkTypeFamilyInstance :: TagKind CTAG
TkDataTypeFamily :: TagKind CTAG
TkDataTypeFamilyInstance :: TagKind CTAG
TkForeignImport :: TagKind CTAG
TkForeignExport :: TagKind CTAG
CharKind :: !Char -> TagKind CTAG
NoKind :: TagKind tk
type CTagKind = TagKind CTAG
type ETagKind = TagKind ETAG
deriving instance Eq (TagKind tk)
deriving instance Ord (TagKind tk)
deriving instance Show (TagKind tk)
newtype ExCommand = ExCommand { getExCommand :: Text }
deriving (Eq, Ord, Show)
data TagAddress (tk :: TAG_KIND) where
TagLineCol :: !Int -> !Int -> TagAddress tk
TagLine :: !Int -> TagAddress CTAG
TagCommand :: !ExCommand -> TagAddress CTAG
type CTagAddress = TagAddress CTAG
type ETagAddress = TagAddress ETAG
deriving instance Eq (TagAddress tk)
deriving instance Ord (TagAddress tk)
deriving instance Show (TagAddress tk)
data TagDefinition (tk :: TAG_KIND) where
TagDefinition :: !Text -> TagDefinition ETAG
NoTagDefinition :: TagDefinition tk
deriving instance Show (TagDefinition tk)
deriving instance Eq (TagDefinition tk)
data TagField = TagField {
fieldName :: Text,
fieldValue :: Text
}
deriving (Eq, Ord, Show)
fileField :: TagField
fileField = TagField { fieldName = "file", fieldValue = "" }
data TagFields (tk :: TAG_KIND) where
NoTagFields :: TagFields ETAG
TagFields :: ![TagField]
-> TagFields CTAG
deriving instance Show (TagFields tk)
deriving instance Eq (TagFields tk)
instance Semigroup (TagFields tk) where
NoTagFields <> NoTagFields = NoTagFields
(TagFields a) <> (TagFields b) = TagFields (a ++ b)
instance Monoid (TagFields CTAG) where
mempty = TagFields mempty
instance Monoid (TagFields ETAG) where
mempty = NoTagFields
type CTagFields = TagFields CTAG
type ETagFields = TagFields ETAG
newtype TagFilePath = TagFilePath { getRawFilePath :: Text }
deriving (Ord, Show)
instance Eq TagFilePath where
(TagFilePath a) == (TagFilePath b) = a == b
data Tag (tk :: TAG_KIND) = Tag
{ tagName :: !TagName
, tagKind :: !(TagKind tk)
, tagFilePath :: !TagFilePath
, tagAddr :: !(TagAddress tk)
, tagDefinition :: !(TagDefinition tk)
, tagFields :: !(TagFields tk)
}
deriving (Show)
instance Eq (Tag tk) where
t0 == t1 = on (==) tagName t0 t1
&& on (==) tagKind t0 t1
&& on (==) tagFilePath t0 t1
&& on (==) tagAddr t0 t1
&& on (==) tagDefinition t0 t1
&& on (==) tagFields t0 t1
type CTag = Tag CTAG
type ETag = Tag ETAG
compareTags :: forall (tk :: TAG_KIND). Ord (TagAddress tk) => Tag tk -> Tag tk -> Ordering
compareTags t0 t1 = on compare tagName t0 t1
<> on compare getTkClass t0 t1
<> on compare tagFilePath t0 t1
<> on compare tagAddr t0 t1
<> on compare tagKind t0 t1
where
getTkClass :: Tag tk -> Maybe (TagKind tk)
getTkClass t = case tagKind t of
TkTypeClass -> Just TkTypeClass
TkTypeClassInstance -> Just TkTypeClassInstance
TkTypeFamily -> Just TkTypeFamily
TkTypeFamilyInstance -> Just TkTypeFamilyInstance
TkDataTypeFamily -> Just TkDataTypeFamily
TkDataTypeFamilyInstance -> Just TkDataTypeFamilyInstance
_ -> Nothing
combineTags :: (Tag tk -> Tag tk -> Ordering)
-> RawFilePath
-> [Tag tk] -> [Tag tk] -> [Tag tk]
combineTags compareFn modPath = go
where
modPathText = Text.decodeUtf8 modPath
go as@(a : as') bs@(b : bs')
| getRawFilePath (tagFilePath b) == modPathText = go as bs'
| otherwise = case a `compareFn` b of
LT -> a : go as' bs
EQ -> a : go as' bs'
GT -> b : go as bs'
go [] bs = filter (\b -> not (getRawFilePath (tagFilePath b) == modPathText)) bs
go as [] = as
{-# INLINE go #-}
ghcTagToTag :: SingTagKind tk -> DynFlags
-> GhcTag -> Maybe (Tag tk)
ghcTagToTag sing dynFlags GhcTag { gtSrcSpan, gtTag, gtKind, gtIsExported, gtFFI } =
case gtSrcSpan of
UnhelpfulSpan {} -> Nothing
RealSrcSpan realSrcSpan ->
Just $ Tag
{ tagName = TagName (Text.decodeUtf8 gtTag)
, tagFilePath = TagFilePath
$ Text.decodeUtf8
$ fs_bs
$ srcSpanFile realSrcSpan
, tagAddr = TagLineCol (srcSpanStartLine realSrcSpan)
(srcSpanStartCol realSrcSpan)
, tagKind =
case sing of
SingCTag -> fromGhcTagKind gtKind
SingETag -> NoKind
, tagDefinition = NoTagDefinition
, tagFields = ( staticField
<> ffiField
<> kindField
) sing
}
where
fromGhcTagKind :: GhcTagKind -> CTagKind
fromGhcTagKind = \case
GtkTerm -> TkTerm
GtkFunction -> TkFunction
GtkTypeConstructor {} -> TkTypeConstructor
GtkDataConstructor {} -> TkDataConstructor
GtkGADTConstructor {} -> TkGADTConstructor
GtkRecordField -> TkRecordField
GtkTypeSynonym {} -> TkTypeSynonym
GtkTypeSignature {} -> TkTypeSignature
GtkPatternSynonym -> TkPatternSynonym
GtkTypeClass -> TkTypeClass
GtkTypeClassMember -> TkTypeClassMember
GtkTypeClassInstance {} -> TkTypeClassInstance
GtkTypeFamily {} -> TkTypeFamily
GtkTypeFamilyInstance -> TkTypeFamilyInstance
GtkDataTypeFamily {} -> TkDataTypeFamily
GtkDataTypeFamilyInstance -> TkDataTypeFamilyInstance
GtkForeignImport -> TkForeignImport
GtkForeignExport -> TkForeignExport
staticField :: SingTagKind tk -> TagFields tk
staticField = \case
SingETag -> NoTagFields
SingCTag ->
TagFields $
if gtIsExported
then mempty
else [fileField]
ffiField :: SingTagKind tk -> TagFields tk
ffiField = \case
SingETag -> NoTagFields
SingCTag ->
TagFields $
case gtFFI of
Nothing -> mempty
Just ffi -> [TagField "ffi" (Text.pack ffi)]
kindField :: SingTagKind tk -> TagFields tk
kindField = \case
SingETag -> NoTagFields
SingCTag ->
case gtKind of
GtkTypeClassInstance hsType ->
mkField "instance" hsType
GtkTypeFamily (Just hsKind) ->
mkField kindFieldName hsKind
GtkDataTypeFamily (Just hsKind) ->
mkField kindFieldName hsKind
GtkTypeSignature hsSigWcType ->
mkField typeFieldName hsSigWcType
GtkTypeSynonym hsType ->
mkField typeFieldName hsType
GtkTypeConstructor (Just hsKind) ->
mkField kindFieldName hsKind
GtkDataConstructor ty fields ->
TagFields
[TagField
{ fieldName = typeFieldName
, fieldValue = Text.intercalate " -> " (map render fields ++ [render ty])
}]
GtkGADTConstructor hsType ->
mkField typeFieldName hsType
_ -> mempty
kindFieldName, typeFieldName :: Text
kindFieldName = "Kind"
typeFieldName = "type"
mkField :: Out.Outputable p => Text -> p -> TagFields CTAG
mkField fieldName p =
TagFields
[ TagField
{ fieldName
, fieldValue = render p
}]
render :: Out.Outputable p => p -> Text
render hsType =
Text.intercalate " "
. Text.words
. Text.pack
$ Out.renderWithStyle
(dynFlags { pprUserLength = 1 })
(Out.ppr hsType)
(Out.setStyleColoured False
$ Out.mkErrStyle dynFlags Out.neverQualify)