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

-- | 'bytestring''s 'Builder' for a 'Tag'
--
module GhcTags.CTag.Formatter
  ( formatTagsFile
  -- * 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.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 :: forall (tk :: TAG_KIND). Tag tk -> TagName
tagName :: TagName
tagName, TagFilePath
tagFilePath :: forall (tk :: TAG_KIND). Tag tk -> TagFilePath
tagFilePath :: TagFilePath
tagFilePath, TagAddress 'CTAG
tagAddr :: forall (tk :: TAG_KIND). Tag tk -> TagAddress tk
tagAddr :: TagAddress 'CTAG
tagAddr, TagKind 'CTAG
tagKind :: forall (tk :: TAG_KIND). Tag tk -> TagKind tk
tagKind :: TagKind 'CTAG
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 'CTAG -> Builder
formatKindChar TagKind 'CTAG
tagKind

    -- tag fields
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (TagField -> Builder) -> [TagField] -> Builder
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 :: CTagKind -> Builder
    formatKindChar :: TagKind 'CTAG -> Builder
formatKindChar TagKind 'CTAG
tk =
      case TagKind 'CTAG -> Maybe Char
tagKindToChar TagKind 'CTAG
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 :: TagField -> Text
fieldName :: Text
fieldName, Text
fieldValue :: TagField -> Text
fieldValue :: 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 :: HeaderType ty
headerType, Maybe Text
headerLanguage :: Header -> Maybe Text
headerLanguage :: Maybe Text
headerLanguage, ty
headerArg :: ()
headerArg :: ty
headerArg, Text
headerComment :: Header -> Text
headerComment :: 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 :: (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 (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 (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 (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| CTag -> Builder
formatTag) [Either Header CTag]
tags