-- | Render an abstract representation of documentation (as produced
-- by `parseGtkDoc`) as Haddock formatted documentation.
module Data.GI.CodeGen.Haddock
  ( deprecatedPragma
  , writeDocumentation
  , RelativeDocPosition(..)
  , writeHaddock
  , writeArgDocumentation
  , writeReturnDocumentation
  , addSectionDocumentation
  ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (mapM_, unless)
import qualified Data.Map as M
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Text (Text)

import Data.GI.GIR.Arg (Arg(..))
import Data.GI.GIR.Callable (Callable(..))
import Data.GI.GIR.Deprecation (DeprecationInfo(..))
import Data.GI.GIR.Documentation (Documentation(..))

import Data.GI.CodeGen.Code (CodeGen, config, line, HaddockSection,
                             getC2HMap, addSectionFormattedDocs)
import Data.GI.CodeGen.Config (modName, overrides)
import Data.GI.CodeGen.CtoHaskellMap (Hyperlink(..))
import Data.GI.CodeGen.GtkDoc (GtkDoc(..), Token(..), CRef(..), Language(..),
                               Link(..), ListItem(..), parseGtkDoc)
import Data.GI.CodeGen.Overrides (onlineDocsMap)
import Data.GI.CodeGen.SymbolNaming (lowerSymbol)

-- | Where is the documentation located with respect to the relevant
-- symbol, useful for determining whether we want to start with @|@ or @^@.
data RelativeDocPosition = DocBeforeSymbol
                         | DocAfterSymbol

-- | Given a `GtkDoc`, a map from C identifiers to Haskell symbols,
-- and a location online where to find the C documentation, render the
-- corresponding Haddock-formatted text. Note that the comment
-- delimiters are not included in the output.
--
-- === __Examples__
-- >>> formatHaddock M.empty "" (GtkDoc [Literal "Hello ", Literal "World!"])
-- "Hello World!"
--
-- >>> let c2h = M.fromList [(FunctionRef "foo", "foo()")]
-- >>> formatHaddock c2h "" (GtkDoc [SymbolRef (FunctionRef "foo")])
-- "'foo()'"
--
-- >>> let onlineDocs = "http://wiki.haskell.org"
-- >>> formatHaddock M.empty onlineDocs (GtkDoc [ExternalLink (Link "GI" "GObjectIntrospection")])
-- "<http://wiki.haskell.org/GObjectIntrospection GI>"
--
-- >>> formatHaddock M.empty "a" (GtkDoc [List [ListItem (GtkDoc [Image (Link "test" "test.png")]) []]])
-- "\n* <<a/test.png test>>\n"
formatHaddock :: M.Map CRef Hyperlink -> Text -> GtkDoc -> Text
formatHaddock c2h docBase (GtkDoc doc) = T.concat $ map formatToken doc
  where formatToken :: Token -> Text
        formatToken (Literal l) = escape l
        formatToken (Verbatim v) = "@" <> escape v <> "@"
        formatToken (CodeBlock l c) = formatCodeBlock l c
        formatToken (ExternalLink l) = formatLink l docBase
        formatToken (Image l) = formatImage l docBase
        formatToken (SectionHeader l h) = formatSectionHeader c2h docBase l h
        formatToken (List l) = formatList c2h docBase l
        formatToken (SymbolRef (ParamRef p)) = "/@" <> lowerSymbol p <> "@/"
        formatToken (SymbolRef cr) = case M.lookup cr c2h of
          Just hr -> formatHyperlink hr
          Nothing -> formatUnknownCRef c2h cr

-- | Format a `CRef` whose Haskell representation is not known.
formatUnknownCRef :: M.Map CRef Hyperlink -> CRef -> Text
formatUnknownCRef _ (FunctionRef f) = formatCRef $ f <> "()"
formatUnknownCRef _ (ParamRef _) = error $ "Should not be reached"
formatUnknownCRef c2h (SignalRef owner signal) =
  case M.lookup (TypeRef owner) c2h of
    Nothing -> formatCRef $ owner <> "::" <> signal
    Just r -> formatHyperlink r <> "::" <> formatCRef signal
formatUnknownCRef c2h (PropertyRef owner prop) =
  case M.lookup (TypeRef owner) c2h of
    Nothing -> formatCRef $ owner <> ":" <> prop
    Just r -> formatHyperlink r <> ":" <> formatCRef prop
formatUnknownCRef c2h (VMethodRef owner vmethod) =
  case M.lookup (TypeRef owner) c2h of
    Nothing -> formatCRef $ owner <> "." <> vmethod <> "()"
    Just r -> formatHyperlink r <> "." <> formatCRef vmethod <> "()"
formatUnknownCRef c2h (StructFieldRef owner field) =
  case M.lookup (TypeRef owner) c2h of
    Nothing -> formatCRef $ owner <> "." <> field
    Just r -> formatHyperlink r <> "." <> formatCRef field
formatUnknownCRef _ (TypeRef t) = formatCRef t
formatUnknownCRef _ (ConstantRef t) = formatCRef t

-- | Formatting for an unknown C reference.
formatCRef :: Text -> Text
formatCRef t = "@/" <> escape t <> "/@"

-- | Format a `Hyperlink` into plain `Text`.
formatHyperlink :: Hyperlink -> Text
formatHyperlink (IdentifierLink t) = "'" <> t <> "'"
formatHyperlink (ModuleLink m) = "\"" <> m <> "\""
formatHyperlink (ModuleLinkWithAnchor m a) = "\"" <> m <> "#" <> a <> "\""

-- | Format a code block in a specified language.
formatCodeBlock :: Maybe Language -> Text -> Text
formatCodeBlock maybeLang code =
  let header = case maybeLang of
        Nothing -> ""
        Just (Language lang) -> "\n=== /" <> lang <> " code/\n"
      birdTrack = T.unlines . map (T.cons '>') . T.lines
  in header <> birdTrack code

-- | Qualify the given address with the docBase, if it is not an
-- absolute address.
qualifiedWith :: Text -> Text -> Text
qualifiedWith address docBase =
  if "http://" `T.isPrefixOf` address || "https://" `T.isPrefixOf` address
  then address
  else if "/" `T.isSuffixOf` docBase
       then docBase <> address
       else docBase <> "/" <> address

-- | Format a link to some external resource.
formatLink :: Link -> Text -> Text
formatLink (Link {linkName = name, linkAddress = address}) docBase =
  let address' = address `qualifiedWith` docBase
      name' = T.replace ">" "\\>" name
  in "<" <> address' <> " " <>  name' <> ">"

-- | Format an embedded image.
formatImage :: Link -> Text -> Text
formatImage (Link {linkName = name, linkAddress = address}) docBase =
  let address' = address `qualifiedWith` docBase
      name' = T.replace ">" "\\>" name
  in if T.null name'
     then "<<" <> address' <> ">>"
     else "<<" <> address' <> " " <>  name' <> ">>"

-- | Format a section header of the given level and with the given
-- text. Note that the level will be truncated to 2, if it is larger
-- than that.
formatSectionHeader :: M.Map CRef Hyperlink -> Text -> Int -> GtkDoc -> Text
formatSectionHeader c2h docBase level header =
  T.replicate level "=" <> " " <> formatHaddock c2h docBase header <> "\n"

-- | Format a list of items.
formatList :: M.Map CRef Hyperlink -> Text -> [ListItem] -> Text
formatList c2h docBase items = "\n" <> T.concat (map formatListItem items)
  where formatListItem :: ListItem -> Text
        formatListItem (ListItem first rest) =
          "* " <> format first <> "\n"
          <> T.concat (map ((<> "\n") . format) rest)

        format :: GtkDoc -> Text
        format = formatHaddock c2h docBase

-- | Escape the reserved Haddock characters in a given `Text`.
--
-- === __Examples__
-- >>> escape "\""
-- "\\\""
--
-- >>> escape "foo@bar.com"
-- "foo\\@bar.com"
--
-- >>> escape "C:\\Applications"
-- "C:\\\\Applications"
escape :: Text -> Text
escape = T.concatMap escapeChar
  where
    escapeChar :: Char -> Text
    escapeChar c = if c `elem` ("\\/'`\"@<" :: [Char])
                   then "\\" <> T.singleton c
                   else T.singleton c

-- | Get the base url for the online C language documentation for the
-- module being currently generated.
getDocBase :: CodeGen Text
getDocBase = do
  mod <- modName <$> config
  docsMap <- (onlineDocsMap . overrides) <$> config
  return $ case M.lookup mod docsMap of
             Just url -> url
             Nothing -> "http://developer.gnome.org/" <> T.toLower mod <>
                        "/stable"

-- | Write the deprecation pragma for the given `DeprecationInfo`, if
-- not `Nothing`.
deprecatedPragma :: Text -> Maybe DeprecationInfo -> CodeGen ()
deprecatedPragma _  Nothing = return ()
deprecatedPragma name (Just info) = do
  c2h <- getC2HMap
  docBase <- getDocBase
  line $ "{-# DEPRECATED " <> name <> " " <>
    (T.pack . show) (note <> reason c2h docBase) <> " #-}"
        where reason c2h docBase =
                case deprecationMessage info of
                  Nothing -> []
                  Just msg -> map (formatHaddock c2h docBase . parseGtkDoc)
                                  (T.lines msg)
              note = case deprecatedSinceVersion info of
                       Nothing -> []
                       Just v -> ["(Since version " <> v <> ")"]

-- | Format the given documentation into a set of lines. Note that
-- this does include the opening or ending comment delimiters.
formatDocumentation :: M.Map CRef Hyperlink -> Text -> Documentation -> Text
formatDocumentation c2h docBase doc = do
  let description = case rawDocText doc of
        Just raw -> formatHaddock c2h docBase (parseGtkDoc raw)
        Nothing -> "/No description available in the introspection data./"
  description <> case sinceVersion doc of
                   Nothing -> ""
                   Just ver -> "\n\n/Since: " <> ver <> "/"

-- | Write the given documentation into generated code.
writeDocumentation :: RelativeDocPosition -> Documentation -> CodeGen ()
writeDocumentation pos doc = do
  line $ case pos of
           DocBeforeSymbol -> "{- |"
           DocAfterSymbol ->  "{- ^"
  c2h <- getC2HMap
  docBase <- getDocBase
  let haddock = formatDocumentation c2h docBase doc
  mapM_ line (T.lines haddock)
  line "-}"

-- | Like `writeDocumentation`, but allows us to pass explicitly the
-- Haddock comment to write.
writeHaddock :: RelativeDocPosition -> Text -> CodeGen ()
writeHaddock pos haddock =
  let marker = case pos of
        DocBeforeSymbol -> "|"
        DocAfterSymbol -> "^"
  in if T.any (== '\n') haddock
     then do
        line $ "{- " <> marker
        mapM_ line (T.lines haddock)
        line $ "-}"
     else line $ "-- " <> marker <> " " <> haddock

-- | Write the documentation for the given argument.
writeArgDocumentation :: Arg -> CodeGen ()
writeArgDocumentation arg =
  case rawDocText (argDoc arg) of
    Nothing -> return ()
    Just raw -> do
      c2h <- getC2HMap
      docBase <- getDocBase
      line $ "{- ^ /@" <> lowerSymbol (argCName arg) <> "@/: " <>
        formatHaddock c2h docBase (parseGtkDoc raw) <> " -}"

-- | Write the documentation for the given return value.
writeReturnDocumentation :: Callable -> Bool -> CodeGen ()
writeReturnDocumentation callable skip = do
  c2h <- getC2HMap
  docBase <- getDocBase
  let returnValInfo = if skip
                      then []
                      else case rawDocText (returnDocumentation callable) of
                             Nothing -> []
                             Just raw -> ["__Returns:__ " <>
                                           formatHaddock c2h docBase
                                           (parseGtkDoc raw)]
      throwsInfo = if callableThrows callable
                   then ["/(Can throw 'Data.GI.Base.GError.GError')/"]
                   else []
  let fullInfo = T.intercalate " " (returnValInfo ++ throwsInfo)
  unless (T.null fullInfo) $
    line $ "{- ^ " <>  fullInfo <> " -}"

-- | Add the given text to the documentation for the section being generated.
addSectionDocumentation :: HaddockSection -> Documentation -> CodeGen ()
addSectionDocumentation section doc = do
  c2h <- getC2HMap
  docBase <- getDocBase
  let formatted = formatDocumentation c2h docBase doc
  addSectionFormattedDocs section formatted