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 Data.Foldable (Foldable)
import qualified Data.Foldable as F
import qualified Data.Sequence as S
import qualified Data.Text as T
import Data.Traversable (Traversable)
import GHC.Generics (Generic)
import Text.Blaze.Html (Html)
data DocTerm = Unchecked
| Checked Term
| Example Term
| Failing Err
deriving (Show, Generic)
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
data Docstring a = DocString CT.Options (Blocks a)
deriving (Show, Functor, Foldable, Traversable, Generic)
type Blocks a = S.Seq (Block a)
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)
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
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
}
renderDocstring :: (a -> String -> Doc OutputAnnotation) -> Docstring a -> Doc OutputAnnotation
renderDocstring pp (DocString _ blocks) = renderBlocks pp blocks
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>"
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>"
renderInline pp (Entity a) = text $ "<entity " ++ T.unpack a ++ ">"
renderInline pp (RawHtml txt) = text "<html content>" --TODO
emptyDocstring :: Docstring a
emptyDocstring = DocString options S.empty
nullDocstring :: Docstring a -> Bool
nullDocstring (DocString _ blocks) = S.null blocks
noDocs :: (Docstring a, [(Name, Docstring a)])
noDocs = (emptyDocstring, [])
containsText :: T.Text -> Docstring a -> Bool
containsText str (DocString _ blocks) = F.any (blockContains (T.toLower str)) blocks
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
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
annotCode :: forall a b. (String -> b)
-> 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