{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
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)
#if __GLASGOW_HASKELL__ < 810
import Data.ByteString (ByteString)
#endif
import qualified Data.ByteString as BS
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import System.FilePath.ByteString (RawFilePath)
#if __GLASGOW_HASKELL__ >= 900
import GHC.Driver.Session (DynFlags)
#else
import DynFlags (DynFlags (pprUserLength))
#endif
#if __GLASGOW_HASKELL__ >= 900
import GHC.Data.FastString (bytesFS)
#elif __GLASGOW_HASKELL__ >= 810
import FastString (bytesFS)
#else
import FastString (FastString (fs_bs))
#endif
#if __GLASGOW_HASKELL__ >= 900
import GHC.Types.SrcLoc
( SrcSpan (..)
, srcSpanFile
, srcSpanStartLine
, srcSpanStartCol
)
#else
import SrcLoc ( SrcSpan (..)
, srcSpanFile
, srcSpanStartLine
, srcSpanStartCol
)
#endif
import GhcTags.Ghc ( GhcTag (..)
, GhcTagKind (..)
)
#if __GLASGOW_HASKELL__ >= 900
import qualified GHC.Utils.Outputable as Out
#else
import qualified Outputable as Out
#endif
#if __GLASGOW_HASKELL__ < 810
bytesFS :: FastString -> ByteString
bytesFS = fs_bs
#endif
data TAG_KIND = CTAG | ETAG
data SingTagKind (tk :: TAG_KIND) where
SingCTag :: SingTagKind CTAG
SingETag :: SingTagKind ETAG
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)
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 { 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)
data TagAddress (tk :: TAG_KIND) where
TagLineCol :: !Int -> !Int -> TagAddress tk
TagLine :: !Int -> TagAddress tk
TagCommand :: !ExCommand -> TagAddress CTAG
NoAddress :: TagAddress ETAG
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 {
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)
fileField :: TagField
fileField :: TagField
fileField = TagField { fieldName :: Text
fieldName = Text
"file", fieldValue :: Text
fieldValue = Text
"" }
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
TagFields tk
NoTagFields <> :: TagFields tk -> TagFields tk -> TagFields tk
<> TagFields tk
NoTagFields = TagFields 'ETAG
NoTagFields
(TagFields [TagField]
a) <> (TagFields [TagField]
b) = [TagField] -> TagFields 'CTAG
TagFields ([TagField]
a forall a. [a] -> [a] -> [a]
++ [TagField]
b)
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
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
data Tag (tk :: TAG_KIND) = Tag
{ forall (tk :: TAG_KIND). Tag tk -> TagName
tagName :: !TagName
, forall (tk :: TAG_KIND). Tag tk -> TagKind tk
tagKind :: !(TagKind tk)
, forall (tk :: TAG_KIND). Tag tk -> TagFilePath
tagFilePath :: !TagFilePath
, forall (tk :: TAG_KIND). Tag tk -> TagAddress tk
tagAddr :: !(TagAddress tk)
, forall (tk :: TAG_KIND). Tag tk -> TagDefinition tk
tagDefinition :: !(TagDefinition tk)
, forall (tk :: TAG_KIND). Tag tk -> TagFields tk
tagFields :: !(TagFields tk)
}
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 tk
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
type CTag = Tag CTAG
type ETag = Tag ETAG
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
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 tk)
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 tk
tagKind Tag tk
t0 Tag tk
t1
where
getTkClass :: Tag tk -> Maybe (TagKind tk)
getTkClass :: Tag tk -> Maybe (TagKind tk)
getTkClass Tag tk
t = case forall (tk :: TAG_KIND). Tag tk -> TagKind tk
tagKind Tag tk
t of
TagKind tk
TkTypeClass -> forall a. a -> Maybe a
Just TagKind 'CTAG
TkTypeClass
TagKind tk
TkTypeClassInstance -> forall a. a -> Maybe a
Just TagKind 'CTAG
TkTypeClassInstance
TagKind tk
TkTypeFamily -> forall a. a -> Maybe a
Just TagKind 'CTAG
TkTypeFamily
TagKind tk
TkTypeFamilyInstance -> forall a. a -> Maybe a
Just TagKind 'CTAG
TkTypeFamilyInstance
TagKind tk
TkDataTypeFamily -> forall a. a -> Maybe a
Just TagKind 'CTAG
TkDataTypeFamily
TagKind tk
TkDataTypeFamilyInstance -> forall a. a -> Maybe a
Just TagKind 'CTAG
TkDataTypeFamilyInstance
TagKind tk
_ -> forall a. Maybe a
Nothing
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 #-}
ghcTagToTag :: SingTagKind tk -> DynFlags
-> GhcTag -> Maybe (Tag tk)
#if __GLASGOW_HASKELL__ >= 902
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 __GLASGOW_HASKELL__ >= 900
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 tk
tagKind =
case SingTagKind tk
sing of
SingTagKind tk
SingCTag -> GhcTagKind -> TagKind 'CTAG
fromGhcTagKind GhcTagKind
gtKind
SingTagKind tk
SingETag -> forall (tk :: TAG_KIND). TagKind tk
NoKind
, 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 -> CTagKind
fromGhcTagKind :: GhcTagKind -> TagKind 'CTAG
fromGhcTagKind = \case
GhcTagKind
GtkTerm -> TagKind 'CTAG
TkTerm
GhcTagKind
GtkFunction -> TagKind 'CTAG
TkFunction
GtkTypeConstructor {} -> TagKind 'CTAG
TkTypeConstructor
GtkDataConstructor {} -> TagKind 'CTAG
TkDataConstructor
GtkGADTConstructor {} -> TagKind 'CTAG
TkGADTConstructor
GhcTagKind
GtkRecordField -> TagKind 'CTAG
TkRecordField
GtkTypeSynonym {} -> TagKind 'CTAG
TkTypeSynonym
GtkTypeSignature {} -> TagKind 'CTAG
TkTypeSignature
GtkTypeKindSignature {} -> TagKind 'CTAG
TkTypeSignature
GhcTagKind
GtkPatternSynonym -> TagKind 'CTAG
TkPatternSynonym
GhcTagKind
GtkTypeClass -> TagKind 'CTAG
TkTypeClass
GtkTypeClassMember {} -> TagKind 'CTAG
TkTypeClassMember
GtkTypeClassInstance {} -> TagKind 'CTAG
TkTypeClassInstance
GtkTypeFamily {} -> TagKind 'CTAG
TkTypeFamily
GtkTypeFamilyInstance {} -> TagKind 'CTAG
TkTypeFamilyInstance
GtkDataTypeFamily {} -> TagKind 'CTAG
TkDataTypeFamily
GtkDataTypeFamilyInstance {} -> TagKind 'CTAG
TkDataTypeFamilyInstance
GhcTagKind
GtkForeignImport -> TagKind 'CTAG
TkForeignImport
GhcTagKind
GtkForeignExport -> TagKind 'CTAG
TkForeignExport
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]
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)]
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
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"
typeFieldName :: Text
typeFieldName = Text
"type"
termFieldName :: Text
termFieldName = Text
"term"
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
" "
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 __GLASGOW_HASKELL__ >= 902
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 __GLASGOW_HASKELL__ >= 900
$ 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