{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module GhcTags.CTag.Formatter
( formatTagsFile
, formatTagsFileMap
, formatTag
, formatHeader
) where
import Control.Arrow ((|||))
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as BS
import Data.Char (isAscii)
import Data.List (sortBy)
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import GhcTags.Tag
import GhcTags.Utils (endOfLine)
import GhcTags.CTag.Header
import GhcTags.CTag.Utils
formatTag :: CTag -> Builder
formatTag :: CTag -> Builder
formatTag Tag { TagName
tagName :: TagName
tagName :: forall (tk :: TAG_KIND). Tag tk -> TagName
tagName, TagFilePath
tagFilePath :: TagFilePath
tagFilePath :: forall (tk :: TAG_KIND). Tag tk -> TagFilePath
tagFilePath, TagAddress 'CTAG
tagAddr :: TagAddress 'CTAG
tagAddr :: forall (tk :: TAG_KIND). Tag tk -> TagAddress tk
tagAddr, TagKind
tagKind :: TagKind
tagKind :: forall (tk :: TAG_KIND). Tag tk -> TagKind
tagKind, tagFields :: forall (tk :: TAG_KIND). Tag tk -> TagFields tk
tagFields = TagFields [TagField]
tagFields } =
(ByteString -> Builder
BS.byteString (ByteString -> Builder)
-> (TagName -> ByteString) -> TagName -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> (TagName -> Text) -> TagName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagName -> Text
getTagName (TagName -> Builder) -> TagName -> Builder
forall a b. (a -> b) -> a -> b
$ TagName
tagName)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BS.charUtf8 Char
'\t'
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BS.byteString (Text -> ByteString
Text.encodeUtf8 (Text -> ByteString)
-> (TagFilePath -> Text) -> TagFilePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagFilePath -> Text
getRawFilePath (TagFilePath -> ByteString) -> TagFilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ TagFilePath
tagFilePath)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BS.charUtf8 Char
'\t'
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TagAddress 'CTAG -> Builder
formatTagAddress TagAddress 'CTAG
tagAddr
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
BS.stringUtf8 String
";\""
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TagKind -> Builder
formatKindChar TagKind
tagKind
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (TagField -> Builder) -> [TagField] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Char -> Builder
BS.charUtf8 Char
'\t' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) (Builder -> Builder)
-> (TagField -> Builder) -> TagField -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagField -> Builder
formatField) [TagField]
tagFields
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
BS.stringUtf8 String
endOfLine
where
formatTagAddress :: CTagAddress -> Builder
formatTagAddress :: TagAddress 'CTAG -> Builder
formatTagAddress (TagLineCol Int
lineNo Int
_colNo) =
Int -> Builder
BS.intDec Int
lineNo
formatTagAddress (TagLine Int
lineNo) =
Int -> Builder
BS.intDec Int
lineNo
formatTagAddress (TagCommand ExCommand
exCommand) =
ByteString -> Builder
BS.byteString (ByteString -> Builder)
-> (ExCommand -> ByteString) -> ExCommand -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 (Text -> ByteString)
-> (ExCommand -> Text) -> ExCommand -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExCommand -> Text
getExCommand (ExCommand -> Builder) -> ExCommand -> Builder
forall a b. (a -> b) -> a -> b
$ ExCommand
exCommand
formatKindChar :: TagKind -> Builder
formatKindChar :: TagKind -> Builder
formatKindChar TagKind
tk =
case TagKind -> Maybe Char
tagKindToChar TagKind
tk of
Maybe Char
Nothing -> Builder
forall a. Monoid a => a
mempty
Just Char
c | Char -> Bool
isAscii Char
c -> Char -> Builder
BS.charUtf8 Char
'\t' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BS.charUtf8 Char
c
| Bool
otherwise -> String -> Builder
BS.stringUtf8 String
"\tkind:" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BS.charUtf8 Char
c
formatField :: TagField -> Builder
formatField :: TagField -> Builder
formatField TagField { Text
fieldName :: Text
fieldName :: TagField -> Text
fieldName, Text
fieldValue :: Text
fieldValue :: TagField -> Text
fieldValue } =
ByteString -> Builder
BS.byteString (Text -> ByteString
Text.encodeUtf8 Text
fieldName)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BS.charUtf8 Char
':'
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BS.byteString (Text -> ByteString
Text.encodeUtf8 Text
fieldValue)
formatHeader :: Header -> Builder
Header { HeaderType ty
headerType :: HeaderType ty
headerType :: ()
headerType, Maybe Text
headerLanguage :: Maybe Text
headerLanguage :: Header -> Maybe Text
headerLanguage, ty
headerArg :: ty
headerArg :: ()
headerArg, Text
headerComment :: Text
headerComment :: Header -> Text
headerComment } =
case HeaderType ty
headerType of
HeaderType ty
FileEncoding ->
Text -> Maybe Text -> Text -> Text -> Builder
formatTextHeaderArgs Text
"FILE_ENCODING" Maybe Text
headerLanguage ty
Text
headerArg Text
headerComment
HeaderType ty
FileFormat ->
Text -> Maybe Text -> Int -> Text -> Builder
formatIntHeaderArgs Text
"FILE_FORMAT" Maybe Text
headerLanguage ty
Int
headerArg Text
headerComment
HeaderType ty
FileSorted ->
Text -> Maybe Text -> Int -> Text -> Builder
formatIntHeaderArgs Text
"FILE_SORTED" Maybe Text
headerLanguage ty
Int
headerArg Text
headerComment
HeaderType ty
OutputMode ->
Text -> Maybe Text -> Text -> Text -> Builder
formatTextHeaderArgs Text
"OUTPUT_MODE" Maybe Text
headerLanguage ty
Text
headerArg Text
headerComment
HeaderType ty
KindDescription ->
Text -> Maybe Text -> Text -> Text -> Builder
formatTextHeaderArgs Text
"KIND_DESCRIPTION" Maybe Text
headerLanguage ty
Text
headerArg Text
headerComment
HeaderType ty
KindSeparator ->
Text -> Maybe Text -> Text -> Text -> Builder
formatTextHeaderArgs Text
"KIND_SEPARATOR" Maybe Text
headerLanguage ty
Text
headerArg Text
headerComment
HeaderType ty
ProgramAuthor ->
Text -> Maybe Text -> Text -> Text -> Builder
formatTextHeaderArgs Text
"PROGRAM_AUTHOR" Maybe Text
headerLanguage ty
Text
headerArg Text
headerComment
HeaderType ty
ProgramName ->
Text -> Maybe Text -> Text -> Text -> Builder
formatTextHeaderArgs Text
"PROGRAM_NAME" Maybe Text
headerLanguage ty
Text
headerArg Text
headerComment
HeaderType ty
ProgramUrl ->
Text -> Maybe Text -> Text -> Text -> Builder
formatTextHeaderArgs Text
"PROGRAM_URL" Maybe Text
headerLanguage ty
Text
headerArg Text
headerComment
HeaderType ty
ProgramVersion ->
Text -> Maybe Text -> Text -> Text -> Builder
formatTextHeaderArgs Text
"PROGRAM_VERSION" Maybe Text
headerLanguage ty
Text
headerArg Text
headerComment
HeaderType ty
ExtraDescription ->
Text -> Maybe Text -> Text -> Text -> Builder
formatTextHeaderArgs Text
"EXTRA_DESCRIPTION" Maybe Text
headerLanguage ty
Text
headerArg Text
headerComment
HeaderType ty
FieldDescription ->
Text -> Maybe Text -> Text -> Text -> Builder
formatTextHeaderArgs Text
"FIELD_DESCRIPTION" Maybe Text
headerLanguage ty
Text
headerArg Text
headerComment
PseudoTag Text
name ->
(Text -> Builder)
-> String -> Text -> Maybe Text -> Text -> Text -> Builder
forall ty.
(ty -> Builder)
-> String -> Text -> Maybe Text -> ty -> Text -> Builder
formatHeaderArgs (ByteString -> Builder
BS.byteString (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8)
String
"!_" Text
name Maybe Text
headerLanguage ty
Text
headerArg Text
headerComment
where
formatHeaderArgs :: (ty -> Builder)
-> String
-> Text
-> Maybe Text
-> ty
-> Text
-> Builder
formatHeaderArgs :: forall ty.
(ty -> Builder)
-> String -> Text -> Maybe Text -> ty -> Text -> Builder
formatHeaderArgs ty -> Builder
formatArg String
prefix Text
headerName Maybe Text
language ty
arg Text
comment =
String -> Builder
BS.stringUtf8 String
prefix
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BS.byteString (Text -> ByteString
Text.encodeUtf8 Text
headerName)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder) -> Maybe Text -> Builder
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Char -> Builder
BS.charUtf8 Char
'!' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) (Builder -> Builder) -> (Text -> Builder) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
BS.byteString (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8) Maybe Text
language
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BS.charUtf8 Char
'\t'
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ty -> Builder
formatArg ty
arg
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
BS.stringUtf8 String
"\t/"
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BS.byteString (Text -> ByteString
Text.encodeUtf8 Text
comment)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BS.charUtf8 Char
'/'
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
BS.stringUtf8 String
endOfLine
formatTextHeaderArgs :: Text -> Maybe Text -> Text -> Text -> Builder
formatTextHeaderArgs = (Text -> Builder)
-> String -> Text -> Maybe Text -> Text -> Text -> Builder
forall ty.
(ty -> Builder)
-> String -> Text -> Maybe Text -> ty -> Text -> Builder
formatHeaderArgs (ByteString -> Builder
BS.byteString (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8) String
"!_TAG_"
formatIntHeaderArgs :: Text -> Maybe Text -> Int -> Text -> Builder
formatIntHeaderArgs = (Int -> Builder)
-> String -> Text -> Maybe Text -> Int -> Text -> Builder
forall ty.
(ty -> Builder)
-> String -> Text -> Maybe Text -> ty -> Text -> Builder
formatHeaderArgs Int -> Builder
BS.intDec String
"!_TAG_"
formatTagsFile :: [Either Header CTag]
-> Builder
formatTagsFile :: [Either Header CTag] -> Builder
formatTagsFile [Either Header CTag]
tags =
(Either Header CTag -> Builder) -> [Either Header CTag] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Header -> Builder
formatHeader (Header -> Builder)
-> (CTag -> Builder) -> Either Header CTag -> Builder
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| CTag -> Builder
formatTag) [Either Header CTag]
tags
formatTagsFileMap :: [Header]
-> CTagMap
-> Builder
formatTagsFileMap :: [Header] -> CTagMap -> Builder
formatTagsFileMap [Header]
headers CTagMap
tags =
(Header -> Builder) -> [Header] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Header -> Builder
formatHeader [Header]
headers
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (CTag -> Builder) -> [CTag] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap CTag -> Builder
formatTag ((CTag -> CTag -> Ordering) -> [CTag] -> [CTag]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy CTag -> CTag -> Ordering
forall (tk :: TAG_KIND).
Ord (TagAddress tk) =>
Tag tk -> Tag tk -> Ordering
compareTags ([CTag] -> [CTag]) -> ([[CTag]] -> [CTag]) -> [[CTag]] -> [CTag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[CTag]] -> [CTag]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CTag]] -> [CTag]) -> [[CTag]] -> [CTag]
forall a b. (a -> b) -> a -> b
$ CTagMap -> [[CTag]]
forall k a. Map k a -> [a]
Map.elems CTagMap
tags)