{-# LANGUAGE GADTs             #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}

-- | 'bytestring''s 'Builder' for a 'Tag'
--
module GhcTags.CTag.Formatter
  ( formatTagsFile
  , formatTagsFileMap
  -- * format a ctag
  , formatTag
  -- * format a pseudo-ctag
  , 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


-- | 'ByteString' 'Builder' for a single line.
--
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
    -- we are using extended format: '_TAG_FILE_FROMAT	2'
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
BS.stringUtf8 String
";\""

    -- tag kind: we are encoding them using field syntax: this is because vim
    -- is using them in the right way: https://github.com/vim/vim/issues/5724
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TagKind -> Builder
formatKindChar TagKind
tagKind

    -- tag fields
    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 -- Vim only allows to use ranges; there's no way to
                       -- specify column (`c|` command is not allowed)
    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
formatHeader :: Header -> Builder
formatHeader 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_"


-- | 'ByteString' 'Builder' for vim 'Tag' file.
--
formatTagsFile :: [Either Header CTag] -- ^ 'CTag's
               -> 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


-- | 'ByteString' 'Builder' for vim 'Tag' file.
--
formatTagsFileMap :: [Header] -- ^ Headers
                  -> CTagMap  -- ^ 'CTag's
                  -> 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)