-----------------------------------------------------------------------------
-- |
-- Module      :  Text.BlogLiterately.Block
-- Copyright   :  (c) 2008-2010 Robert Greayer, 2012 Brent Yorgey
-- License     :  GPL (see LICENSE)
-- Maintainer  :  Brent Yorgey <byorgey@gmail.com>
--
-- Utilities for working with code blocks.
--
-----------------------------------------------------------------------------

module Text.BlogLiterately.Block
    (
      unTag
    , onTag
    ) where

import           Data.Text        (Text)
import qualified Data.Text        as T
import           Text.Pandoc      (Attr, Block (CodeBlock))
import           Text.Parsec
import           Text.Parsec.Text

-- switch to megaparsec, use e.g. https://hackage.haskell.org/package/megaparsec-8.0.0/docs/Text-Megaparsec.html#v:takeWhileP ?

-- | Given a block, if it begins with a tag in square brackets, strip off
--   the tag and return a pair consisting of the tag and de-tagged
--   block.  Otherwise, return @Nothing@ and the unchanged block.
unTag :: Text -> (Maybe Text, Text)
unTag :: Text -> (Maybe Text, Text)
unTag Text
s = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const (forall a. Maybe a
Nothing, Text
s)) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse Parser (Maybe Text, Text)
tag SourceName
"" Text
s
  where
    tag :: Parser (Maybe Text, Text)
    tag :: Parser (Maybe Text, Text)
tag = do
      Text
tg <- SourceName -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'[') (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']') forall a b. (a -> b) -> a -> b
$ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
SourceName -> ParsecT s u m Char
noneOf SourceName
"[]")
      forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
SourceName -> ParsecT s u m Char
oneOf SourceName
" \t"
      SourceName
_   <- (forall s (m :: * -> *) u.
Stream s m Char =>
SourceName -> ParsecT s u m SourceName
string SourceName
"\r\n" forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
SourceName -> ParsecT s u m SourceName
string SourceName
"\n")
      Text
txt <- SourceName -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken
      forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Text
tg, Text
txt)

-- | Run the given function on the attributes and source code of code
--   blocks with a tag matching the given tag (case insensitive).  On
--   any other blocks (which don't have a matching tag, or are not code
--   blocks), run the other function.
onTag :: Text -> (Attr -> Text -> a) -> (Block -> a) -> Block -> a
onTag :: forall a. Text -> (Attr -> Text -> a) -> (Block -> a) -> Block -> a
onTag Text
t Attr -> Text -> a
f Block -> a
def b :: Block
b@(CodeBlock attr :: Attr
attr@(Text
_, [Text]
as, [(Text, Text)]
_) Text
s)
  | Text -> Text
T.toLower Text
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.toLower (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe Text
tag forall a b. (a -> b) -> a -> b
$ [Text]
as)
    = Attr -> Text -> a
f Attr
attr Text
src
  | Bool
otherwise = Block -> a
def Block
b
  where (Maybe Text
tag, Text
src) = Text -> (Maybe Text, Text)
unTag Text
s
onTag Text
_ Attr -> Text -> a
_ Block -> a
def Block
b = Block -> a
def Block
b