module GhcTags.Tag
  ( -- * Tag
    TagType (..)
  , SingTagType (..)
  , Tag (..)
  , ETag
  , CTag
  , ETagMap
  , CTagMap
    -- ** Tag fields
  , TagName (..)
  , TagFileName (..)
  , ExCommand (..)
  , TagAddress (..)
  , CTagAddress
  , ETagAddress
  , TagKind (..)
  , CTagKind
  , ETagKind
  , TagDefinition (..)
  , TagFields (..)
  , CTagFields
  , ETagFields
  , TagField (..)
    -- ** Ordering and combining tags
  , compareTags

  -- * Create 'Tag' from a 'GhcTag'
  , ghcTagToTag
  ) where

import           Control.DeepSeq
import           Data.Function (on)
import           Data.Map.Strict (Map)
import           Data.Text   (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text

-- GHC imports
import           GHC.Driver.Session (DynFlags, initSDocContext)
import           GHC.Data.FastString (bytesFS)

import           GHC.Types.SrcLoc
                              ( SrcSpan (..)
                              , srcSpanFile
                              , srcSpanStartLine
                              )

import           GhcTags.Ghc  ( GhcTag (..)
                              , GhcTagKind (..)
                              )
import qualified GHC.Utils.Outputable as Out

--
-- Tag
--

-- | Promoted data type used to disntinguish 'CTag's from 'ETag's.
--
data TagType = CTag | ETag
  deriving Show


-- | Singletons for promoted types.
--
data SingTagType (tt :: TagType) where
    SingCTag :: SingTagType 'CTag
    SingETag :: SingTagType 'ETag


-- | 'ByteString' which encodes a tag name.
--
newtype TagName = TagName { getTagName :: Text }
  deriving (Eq, Ord, Show)

instance NFData TagName where
  rnf = rnf . getTagName

-- | 'ByteString' which encodes a tag file name.
--
newtype TagFileName = TagFileName { getTagFileName :: Text }
  deriving (Eq, Ord, Show)

instance NFData TagFileName where
  rnf = rnf . getTagFileName

-- | When we parse a `tags` file we can eithera find no kind or recognize the
-- kind of GhcTagKind or we store the found character kind.  This allows us to
-- preserve information from parsed tags files which were not created by
-- `ghc-tags-plugin'
--
-- * 'TkModule' - @`@
-- * 'TkTerm' - @`@
-- * 'TkFunction' - @λ@
-- * 'TkTypeConstructor' - @Λ@
-- * 'TkDataConstructor' - @c@
-- * 'TkGADTConstructor' - @g@
-- * 'TkRecordField' - @r@
-- * 'TkTypeSynonym' - @≡@
-- * 'TkTypeSignature' - @⊢@
-- * 'TkPatternSynonym' - @p@
-- * 'TkTypeClass' - @C@
-- * 'TkTypeClassMember' - @m@
-- * 'TkTypeClassInstance' - @i@
-- * 'TkTypeFamily' - @f@
-- * 'TkTypeFamilyInstance' - @F@
-- * 'TkDataTypeFamily' - @d@
-- * 'TkDataTypeFamilyInstance' - @D@
-- * 'TkForeignImport' - @I@
-- * 'TkForeignExport' - @E@
--
data TagKind (tt :: TagType) where
    TkModule                 :: TagKind tt
    TkTerm                   :: TagKind tt
    TkFunction               :: TagKind tt
    TkTypeConstructor        :: TagKind tt
    TkDataConstructor        :: TagKind tt
    TkGADTConstructor        :: TagKind tt
    TkRecordField            :: TagKind tt
    TkTypeSynonym            :: TagKind tt
    TkTypeSignature          :: TagKind tt
    TkPatternSynonym         :: TagKind tt
    TkTypeClass              :: TagKind tt
    TkTypeClassMember        :: TagKind tt
    TkTypeClassInstance      :: TagKind tt
    TkTypeFamily             :: TagKind tt
    TkTypeFamilyInstance     :: TagKind tt
    TkDataTypeFamily         :: TagKind tt
    TkDataTypeFamilyInstance :: TagKind tt
    TkForeignImport          :: TagKind tt
    TkForeignExport          :: TagKind tt
    CharKind                 :: Char -> TagKind tt
    NoKind                   :: TagKind tt

instance NFData (TagKind tt) where
  rnf x = x `seq` ()

type CTagKind = TagKind 'CTag
type ETagKind = TagKind 'ETag

deriving instance Eq   (TagKind tt)
deriving instance Ord  (TagKind tt)
deriving instance Show (TagKind tt)


newtype ExCommand = ExCommand { getExCommand :: Text }
  deriving (Eq, Ord, Show)


-- | Tag address, either from a parsed file or from Haskell's AST>
--
data TagAddress (tt :: TagType) where
      -- | Address of an etag is a line number and byte offset from the begining
      -- of the file.
      --
      TagLineOff :: Int -> Int -> TagAddress 'ETag

      -- | ctags can only use range ex-commands as an address (or a sequence of
      -- them separated by `;`). We parse line number specifically, since they
      -- are useful for ordering tags.
      --
      TagLine :: Int -> TagAddress 'CTag

      -- | A tag address can be just an ex command.
      --
      TagCommand :: ExCommand -> TagAddress 'CTag

instance NFData (TagAddress tt) where
  rnf x = x `seq` ()

-- | 'CTag' addresses.
--
type CTagAddress = TagAddress 'CTag

-- | 'ETag' addresses.
--
type ETagAddress = TagAddress 'ETag


deriving instance Eq   (TagAddress tt)
deriving instance Ord  (TagAddress tt)
deriving instance Show (TagAddress tt)


-- | Emacs tags specific field.
--
data TagDefinition (tt :: TagType) where
      TagDefinition   :: Text -> TagDefinition 'ETag
      NoTagDefinition :: TagDefinition tt

instance NFData (TagDefinition tt) where
  rnf x = x `seq` ()

deriving instance Show (TagDefinition tt)
deriving instance Eq   (TagDefinition tt)

-- | Unit of data associated with a tag.  Vim natively supports `file:` and
-- `kind:` tags but it can display any other tags too.
--
data TagField = TagField {
      fieldName  :: Text,
      fieldValue :: Text
    }
  deriving (Eq, Ord, Show)

instance NFData TagField where
  rnf x = x `seq` ()

-- | File field; tags which contain 'fileField' are called static (aka static
-- in @C@), such tags are only visible in the current file)
--
fileField :: TagField
fileField = TagField { fieldName = "file", fieldValue = "" }


-- | Ctags specific list of 'TagField's.
--
data TagFields (tt :: TagType) where
    NoTagFields :: TagFields 'ETag

    TagFields   :: [TagField]
                -> TagFields 'CTag

instance NFData (TagFields tt) where
  rnf NoTagFields    = ()
  rnf (TagFields fs) = rnf fs

deriving instance Show (TagFields tt)
deriving instance Eq   (TagFields tt)
instance Semigroup (TagFields tt) 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


-- | Tag record.  For either ctags or etags formats.  It is either filled with
-- information parsed from a tags file or from *GHC* ast.
--
data Tag (tt :: TagType) = Tag
  { tagName       :: TagName
    -- ^ name of the tag
  , tagKind       :: TagKind tt
    -- ^ ctags specifc field, which classifies tags
  , tagAddr       :: TagAddress tt
    -- ^ address in source file
  , tagDefinition :: TagDefinition tt
    -- ^ etags specific field; only tags read from emacs tags file contain this
    -- field.
  , tagFields     :: TagFields tt
    -- ^ ctags specific field
  }
  deriving (Show, Eq)

instance NFData (Tag tt) where
  rnf Tag{..} = rnf tagName
          `seq` rnf tagKind
          `seq` rnf tagAddr
          `seq` rnf tagDefinition
          `seq` rnf tagFields

type CTag = Tag 'CTag
type ETag = Tag 'ETag

type TagMap tt = Map TagFileName [Tag tt]
type CTagMap = TagMap 'CTag
type ETagMap = TagMap 'ETag

-- | Total order relation on 'Tag' elements.
--
-- It sorts type classes / type families ('TkTypeClass', 'TkTypeFamily',
-- 'TkDataTypeFamily')  before instances ('TkTypeClassInstance',
-- 'TkTypeFamilyInstance', 'TkDataTypeFamilyInstance'); but also (as a side
-- effect of keeping transitivity property) it will put type classes and their
-- instances before other kinds.
--
-- It satisfies the following properties:
--
-- * anti-symmetry
-- * reflexivity
-- * transitivity
-- * partial consistency with 'Eq' instance: 
--
--   prop> a == b => compareTags a b == EQ
--
compareTags :: forall (tt :: TagType). Ord (TagAddress tt) => Tag tt -> Tag tt -> Ordering
compareTags t0 t1 = on compare tagName t0 t1
                    -- sort type classes / type families before their instances,
                    -- and take precendence over a file where they are defined.
                    -- 
                    -- This will also sort type classes and instances before any
                    -- other terms.
                 <> on compare getTkClass  t0 t1
                 <> on compare tagAddr     t0 t1
                 <> on compare tagKind     t0 t1

    where
      getTkClass :: Tag tt -> Maybe (TagKind tt)
      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

--
--  GHC interface
--

-- | Create a 'Tag' from 'GhcTag'.
--
ghcTagToTag :: SingTagType tt -> DynFlags -> GhcTag -> Maybe (TagFileName, Tag tt)
ghcTagToTag sing dynFlags GhcTag { gtSrcSpan, gtTag, gtKind, gtIsExported, gtFFI } =
    case gtSrcSpan of
      UnhelpfulSpan {} -> Nothing
      RealSrcSpan realSrcSpan _ ->
        Just . (fileName realSrcSpan, ) $ Tag
          { tagName       = TagName tagName 

          , tagAddr       = case sing of
                              SingETag -> TagLineOff (srcSpanStartLine realSrcSpan) 0
                              SingCTag -> TagLine    (srcSpanStartLine realSrcSpan)

          , tagKind       = fromGhcTagKind gtKind

          , tagDefinition = NoTagDefinition

          , tagFields     = (    staticField
                              <> ffiField
                              <> kindField
                            ) sing
          }

  where
    fileName = TagFileName . Text.decodeUtf8 . bytesFS . srcSpanFile

    tagName = Text.decodeUtf8 gtTag

    fromGhcTagKind :: GhcTagKind -> TagKind tt
    fromGhcTagKind = \case
      GtkModule                    -> TkModule
      GtkTerm                      -> TkTerm
      GtkFunction                  -> TkFunction
      GtkTypeConstructor {}        -> TkTypeConstructor
      GtkDataConstructor {}        -> TkDataConstructor
      GtkGADTConstructor {}        -> TkGADTConstructor
      GtkRecordField               -> TkRecordField
      GtkTypeSynonym {}            -> TkTypeSynonym
      GtkTypeSignature {}          -> TkTypeSignature
      GtkTypeKindSignature {}      -> TkTypeSignature
      GtkPatternSynonym            -> TkPatternSynonym
      GtkTypeClass                 -> TkTypeClass
      GtkTypeClassMember {}        -> TkTypeClassMember
      GtkTypeClassInstance {}      -> TkTypeClassInstance
      GtkTypeFamily {}             -> TkTypeFamily
      GtkTypeFamilyInstance {}     -> TkTypeFamilyInstance
      GtkDataTypeFamily {}         -> TkDataTypeFamily
      GtkDataTypeFamilyInstance {} -> TkDataTypeFamilyInstance
      GtkForeignImport             -> TkForeignImport
      GtkForeignExport             -> TkForeignExport

    -- static field (wheather term is exported or not)
    staticField :: SingTagType tt -> TagFields tt
    staticField = \case
      SingETag -> NoTagFields
      SingCTag ->
        TagFields $
          if gtIsExported
            then mempty
            else [fileField]

    -- ffi field
    ffiField :: SingTagType tt -> TagFields tt
    ffiField = \case
      SingETag -> NoTagFields
      SingCTag ->
        TagFields $
          case gtFFI of
            Nothing  -> mempty
            Just ffi -> [TagField "ffi" $ Text.pack ffi]


    -- 'TagFields' from 'GhcTagKind'
    kindField :: SingTagType tt -> TagFields tt
    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 decl ->
            TagFields
              [TagField
                { fieldName  = termFieldName
                , fieldValue = render decl
                }]


          GtkGADTConstructor hsType ->
            mkField typeFieldName hsType

          _ -> mempty


    kindFieldName, typeFieldName, termFieldName :: Text
    kindFieldName = "Kind" -- "kind" is reserverd
    typeFieldName = "type"
    termFieldName = "term"

    --
    -- fields
    --
    
    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 " " -- remove all line breaks, tabs and multiple spaces
      . Text.words
      . Text.pack
      $ Out.renderWithContext
          (initSDocContext
            dynFlags
            (Out.setStyleColoured False
              $ Out.mkErrStyle Out.neverQualify))
          (Out.ppr hsType)