content: {-|
  Module      :  Idris.Docstrings
  Description : Wrapper around Markdown library.
  
  License     : BSD3
  Maintainer  : The Idris Community.
  -}
  
  {-# LANGUAGE CPP, DeriveFoldable, DeriveFunctor, DeriveGeneric,
               DeriveTraversable, ScopedTypeVariables #-}
  {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
  module Idris.Docstrings (
      Docstring(..), Block(..), Inline(..), parseDocstring, renderDocstring
    , emptyDocstring, nullDocstring, noDocs, overview, containsText
    , renderHtml, annotCode, DocTerm(..), renderDocTerm, checkDocstring
    ) where
  
  import Idris.Core.TT (Err, Name, OutputAnnotation(..), Term, TextFormatting(..))
  
  import Util.Pretty
  
  #if (MIN_VERSION_base(4,11,0))
  import Prelude hiding ((<$>), (<>))
  #else
  import Prelude hiding ((<$>))
  #endif
  import qualified Cheapskate as C
  import Cheapskate.Html (renderDoc)
  import qualified Cheapskate.Types as CT
  import qualified Data.Foldable as F
  import qualified Data.Sequence as S
  import qualified Data.Text as T
  import GHC.Generics (Generic)
  import Text.Blaze.Html (Html)
  
  -- | The various kinds of code samples that can be embedded in docs
  data DocTerm = Unchecked
               | Checked Term
               | Example Term
               | Failing Err
    deriving (Show, Generic)
  
  -- | Render a term in the documentation
  renderDocTerm :: (Term -> Doc OutputAnnotation) -> (Term -> Term) -> DocTerm -> String -> Doc OutputAnnotation
  renderDocTerm pp norm Unchecked     src = text src
  renderDocTerm pp norm (Checked tm)  src = pp tm
  renderDocTerm pp norm (Example tm)  src = align $
                                                  text ">" <+> align (pp tm) <$>
                                                  pp (norm tm)
  renderDocTerm pp norm (Failing err) src = annotate (AnnErr err) $ text src
  
  -- | Representation of Idris's inline documentation. The type paramter
  -- represents the type of terms that are associated with code blocks.
  data Docstring a = DocString CT.Options (Blocks a)
    deriving (Show, Functor, Foldable, Traversable, Generic)
  
  type Blocks a = S.Seq (Block a)
  
  -- | Block-level elements.
  data Block a = Para (Inlines a)
               | Header Int (Inlines a)
               | Blockquote (Blocks a)
               | List Bool CT.ListType [Blocks a]
               | CodeBlock CT.CodeAttr T.Text a
               | HtmlBlock T.Text
               | HRule
               deriving (Show, Functor, Foldable, Traversable, Generic)
  
  data Inline a = Str T.Text
                | Space
                | SoftBreak
                | LineBreak
                | Emph (Inlines a)
                | Strong (Inlines a)
                | Code T.Text a
                | Link (Inlines a) T.Text T.Text
                | Image (Inlines a) T.Text T.Text
                | Entity T.Text
                | RawHtml T.Text
                deriving (Show, Functor, Foldable, Traversable, Generic)
  
  type Inlines a = S.Seq (Inline a)
  
  
  -- | Run some kind of processing step over code in a Docstring. The code
  -- processor gets the language and annotations as parameters, along with the
  -- source and the original annotation.
  checkDocstring :: forall a b. (String -> [String] -> String -> a -> b) -> Docstring a -> Docstring b
  checkDocstring f (DocString opts blocks) = DocString opts (fmap (checkBlock f) blocks)
    where checkBlock :: (String -> [String] -> String -> a -> b) -> Block a -> Block b
          checkBlock f (Para inlines)           = Para (fmap (checkInline f) inlines)
          checkBlock f (Header i inlines)       = Header i (fmap (checkInline f) inlines)
          checkBlock f (Blockquote bs)          = Blockquote (fmap (checkBlock f) bs)
          checkBlock f (List b t blocks)        = List b t (fmap (fmap (checkBlock f)) blocks)
          checkBlock f (CodeBlock attrs src tm) = CodeBlock attrs src
                                                            (f (T.unpack $ CT.codeLang attrs)
                                                               (words . T.unpack $ CT.codeInfo attrs)
                                                               (T.unpack src)
                                                               tm)
          checkBlock f (HtmlBlock src)          = HtmlBlock src
          checkBlock f HRule                    = HRule
  
          checkInline :: (String -> [String] -> String -> a -> b) -> Inline a -> Inline b
          checkInline f (Str txt)            = Str txt
          checkInline f Space                = Space
          checkInline f SoftBreak            = SoftBreak
          checkInline f LineBreak            = LineBreak
          checkInline f (Emph is)            = Emph (fmap (checkInline f) is)
          checkInline f (Strong is)          = Strong (fmap (checkInline f) is)
          checkInline f (Code src x)         = Code src (f "" [] (T.unpack src) x)
          checkInline f (Link is url title)  = Link (fmap (checkInline f) is) url title
          checkInline f (Image is url title) = Image (fmap (checkInline f) is) url title
          checkInline f (Entity txt)         = Entity txt
          checkInline f (RawHtml src)        = RawHtml src
  
  -- | Construct a docstring from a Text that contains Markdown-formatted docs
  parseDocstring :: T.Text -> Docstring ()
  parseDocstring = toDocstring . C.markdown options
    where toDocstring :: CT.Doc -> Docstring ()
          toDocstring (CT.Doc opts blocks) = DocString opts (fmap toBlock blocks)
  
          toBlock :: CT.Block -> Block ()
          toBlock (CT.Para inlines)         = Para (fmap toInline inlines)
          toBlock (CT.Header i inlines)     = Header i (fmap toInline inlines)
          toBlock (CT.Blockquote blocks)    = Blockquote (fmap toBlock blocks)
          toBlock (CT.List b t blocks)      = List b t (fmap (fmap toBlock) blocks)
          toBlock (CT.CodeBlock attrs text) = CodeBlock attrs text ()
          toBlock (CT.HtmlBlock src)        = HtmlBlock src
          toBlock CT.HRule                  = HRule
  
          toInline :: CT.Inline -> Inline ()
          toInline (CT.Str t)              = Str t
          toInline CT.Space                = Space
          toInline CT.SoftBreak            = SoftBreak
          toInline CT.LineBreak            = LineBreak
          toInline (CT.Emph is)            = Emph (fmap toInline is)
          toInline (CT.Strong is)          = Strong (fmap toInline is)
          toInline (CT.Code src)           = Code src ()
          toInline (CT.Link is url title)  = Link (fmap toInline is) url title
          toInline (CT.Image is url title) = Image (fmap toInline is) url title
          toInline (CT.Entity txt)         = Entity txt
          toInline (CT.RawHtml src)        = RawHtml src
  
  
  options = CT.Options { CT.sanitize = True
                       , CT.allowRawHtml = False
                       , CT.preserveHardBreaks = True
                       , CT.debug = False
                       }
  
  -- | Convert a docstring to be shown by the pretty-printer
  renderDocstring :: (a -> String -> Doc OutputAnnotation) -> Docstring a -> Doc OutputAnnotation
  renderDocstring pp (DocString _ blocks) = renderBlocks pp blocks
  
  -- | Construct a docstring consisting of the first block-level element of the
  -- argument docstring, for use in summaries.
  overview :: Docstring a -> Docstring a
  overview (DocString opts blocks) = DocString opts (S.take 1 blocks)
  
  renderBlocks :: (a -> String -> Doc OutputAnnotation)
               -> Blocks a -> Doc OutputAnnotation
  renderBlocks pp blocks  | S.length blocks > 1  = F.foldr1 (\b1 b2 -> b1 <> line <> line <> b2) $
                                                    fmap (renderBlock pp) blocks
                          | S.length blocks == 1 = renderBlock pp (S.index blocks 0)
                          | otherwise            = empty
  
  renderBlock :: (a -> String -> Doc OutputAnnotation)
              -> Block a -> Doc OutputAnnotation
  renderBlock pp (Para inlines) = renderInlines pp inlines
  renderBlock pp (Header lvl inlines) = renderInlines pp inlines <+> parens (text (show lvl))
  renderBlock pp (Blockquote blocks) = indent 8 $ renderBlocks pp blocks
  renderBlock pp (List b ty blockss) = renderList pp b ty blockss
  renderBlock pp (CodeBlock attr src tm) = indent 4 $ pp tm (T.unpack src)
  renderBlock pp (HtmlBlock txt) = text "<html block>" -- TODO
  renderBlock pp HRule = text "----------------------"
  
  renderList :: (a -> String -> Doc OutputAnnotation)
             -> Bool -> CT.ListType -> [Blocks a] -> Doc OutputAnnotation
  renderList pp b (CT.Bullet c) blockss = vsep $ map (hang 4 . (char c <+>) . renderBlocks pp) blockss
  renderList pp b (CT.Numbered nw i) blockss =
    vsep $
    zipWith3 (\n p txt -> hang 4 $ text (show n) <> p <+> txt)
             [i..] (repeat punc) (map (renderBlocks pp) blockss)
    where punc = case nw of
                   CT.PeriodFollowing -> char '.'
                   CT.ParenFollowing  -> char '('
  
  renderInlines :: (a -> String -> Doc OutputAnnotation) -> Inlines a -> Doc OutputAnnotation
  renderInlines pp = F.foldr (<>) empty . fmap (renderInline pp)
  
  renderInline :: (a -> String -> Doc OutputAnnotation) -> Inline a -> Doc OutputAnnotation
  renderInline pp (Str s) = text $ T.unpack s
  renderInline pp Space = softline
  renderInline pp SoftBreak = softline
  renderInline pp LineBreak = line
  renderInline pp (Emph txt) = annotate (AnnTextFmt ItalicText) $ renderInlines pp txt
  renderInline pp (Strong txt) = annotate (AnnTextFmt BoldText) $ renderInlines pp txt
  renderInline pp (Code txt tm) = pp tm $ T.unpack txt
  renderInline pp (Link body url title) = annotate (AnnLink (T.unpack url)) (renderInlines pp body)
  renderInline pp (Image body url title) = text "<image>" -- TODO
  renderInline pp (Entity a) = text $ "<entity " ++ T.unpack a ++ ">" -- TODO
  renderInline pp (RawHtml txt) = text "<html content>" --TODO
  
  -- | The empty docstring
  emptyDocstring :: Docstring a
  emptyDocstring = DocString options S.empty
  
  -- | Check whether a docstring is emtpy
  nullDocstring :: Docstring a -> Bool
  nullDocstring (DocString _ blocks) = S.null blocks
  
  -- | Empty documentation for a definition
  noDocs :: (Docstring a, [(Name, Docstring a)])
  noDocs = (emptyDocstring, [])
  
  -- | Does a string occur in the docstring?
  containsText ::  T.Text -> Docstring a -> Bool
  containsText str (DocString _ blocks) = F.any (blockContains (T.toLower str)) blocks
    -- blockContains and inlineContains should always be called with a lower-case search string
    where blockContains :: T.Text -> Block a -> Bool
          blockContains str (Para inlines) = F.any (inlineContains str) inlines
          blockContains str (Header lvl inlines) = F.any (inlineContains str) inlines
          blockContains str (Blockquote blocks) = F.any (blockContains str) blocks
          blockContains str (List b ty blockss) = F.any (F.any (blockContains str)) blockss
          blockContains str (CodeBlock attr src _) = T.isInfixOf str (T.toLower src)
          blockContains str (HtmlBlock txt) = False -- TODO
          blockContains str HRule = False
  
          inlineContains :: T.Text -> Inline a -> Bool
          inlineContains str (Str s) = T.isInfixOf str (T.toLower s)
          inlineContains str Space = False
          inlineContains str SoftBreak = False
          inlineContains str LineBreak = False
          inlineContains str (Emph txt) = F.any (inlineContains str) txt
          inlineContains str (Strong txt) = F.any (inlineContains str) txt
          inlineContains str (Code txt _) = T.isInfixOf str (T.toLower txt)
          inlineContains str (Link body url title) = F.any (inlineContains str) body
          inlineContains str (Image body url title) = False
          inlineContains str (Entity a) = False
          inlineContains str (RawHtml txt) = T.isInfixOf str (T.toLower txt)
  
  
  renderHtml :: Docstring DocTerm -> Html
  renderHtml = renderDoc . fromDocstring
    where
      fromDocstring :: Docstring DocTerm -> CT.Doc
      fromDocstring (DocString opts blocks) = CT.Doc opts (fmap fromBlock blocks)
  
      fromBlock :: Block DocTerm -> CT.Block
      fromBlock (Para inlines)           = CT.Para (fmap fromInline inlines)
      fromBlock (Header i inlines)       = CT.Header i (fmap fromInline inlines)
      fromBlock (Blockquote blocks)      = CT.Blockquote (fmap fromBlock blocks)
      fromBlock (List b t blocks)        = CT.List b t (fmap (fmap fromBlock) blocks)
      fromBlock (CodeBlock attrs text _) = CT.CodeBlock attrs text
      fromBlock (HtmlBlock src)          = CT.HtmlBlock src
      fromBlock HRule                    = CT.HRule
  
      fromInline :: Inline DocTerm -> CT.Inline
      fromInline (Str t)              = CT.Str t
      fromInline Space                = CT.Space
      fromInline SoftBreak            = CT.SoftBreak
      fromInline LineBreak            = CT.LineBreak
      fromInline (Emph is)            = CT.Emph (fmap fromInline is)
      fromInline (Strong is)          = CT.Strong (fmap fromInline is)
      fromInline (Code src _)         = CT.Code src
      fromInline (Link is url title)  = CT.Link (fmap fromInline is) url title
      fromInline (Image is url title) = CT.Image (fmap fromInline is) url title
      fromInline (Entity txt)         = CT.Entity txt
      fromInline (RawHtml src)        = CT.RawHtml src
  
  
  -- | Annotate the code samples in a docstring
  annotCode :: forall a b. (String -> b) -- ^ How to annotate code samples
            -> Docstring a
            -> Docstring b
  annotCode annot (DocString opts blocks)
      = DocString opts $ fmap annotCodeBlock blocks
    where
      annotCodeBlock :: Block a -> Block b
      annotCodeBlock (Para inlines)          = Para (fmap annotCodeInline inlines)
      annotCodeBlock (Header i inlines)      = Header i (fmap annotCodeInline inlines)
      annotCodeBlock (Blockquote blocks)     = Blockquote (fmap annotCodeBlock blocks)
      annotCodeBlock (List b t blocks)       = List b t (fmap (fmap annotCodeBlock) blocks)
      annotCodeBlock (CodeBlock attrs src _) = CodeBlock attrs src (annot (T.unpack src))
      annotCodeBlock (HtmlBlock src)         = HtmlBlock src
      annotCodeBlock HRule                   = HRule
  
      annotCodeInline :: Inline a -> Inline b
      annotCodeInline (Str t)              = Str t
      annotCodeInline Space                = Space
      annotCodeInline SoftBreak            = SoftBreak
      annotCodeInline LineBreak            = LineBreak
      annotCodeInline (Emph is)            = Emph (fmap annotCodeInline is)
      annotCodeInline (Strong is)          = Strong (fmap annotCodeInline is)
      annotCodeInline (Code src _)         = Code src (annot (T.unpack src))
      annotCodeInline (Link is url title)  = Link (fmap annotCodeInline is) url title
      annotCodeInline (Image is url title) = Image (fmap annotCodeInline is) url title
      annotCodeInline (Entity txt)         = Entity txt
      annotCodeInline (RawHtml src)        = RawHtml src
  