{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP               #-}
{- |
   Module      : Text.Pandoc.Writers.OPML
   Copyright   : Copyright (C) 2013-2020 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Conversion of 'Pandoc' documents to OPML XML.
-}
module Text.Pandoc.Writers.OPML ( writeOPML) where
import Data.Text (Text)
import qualified Data.Text as T
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Data.Time
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.DocLayout
import Text.Pandoc.Shared
import Text.Pandoc.Templates (renderTemplate)
import Text.Pandoc.Writers.HTML (writeHtml5String)
import Text.Pandoc.Writers.Markdown (writeMarkdown)
import Text.Pandoc.Writers.Shared
import Text.Pandoc.XML

-- | Convert Pandoc document to string in OPML format.
writeOPML :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeOPML :: WriterOptions -> Pandoc -> m Text
writeOPML WriterOptions
opts (Pandoc Meta
meta [Block]
blocks) = do
  let colwidth :: Maybe Int
colwidth = if WriterOptions -> WrapOption
writerWrapText WriterOptions
opts WrapOption -> WrapOption -> Bool
forall a. Eq a => a -> a -> Bool
== WrapOption
WrapAuto
                    then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Int
writerColumns WriterOptions
opts
                    else Maybe Int
forall a. Maybe a
Nothing
      meta' :: Meta
meta' = Text -> Inlines -> Meta -> Meta
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
B.setMeta Text
"date" (Text -> Inlines
B.str (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ [Inline] -> Text
convertDate ([Inline] -> Text) -> [Inline] -> Text
forall a b. (a -> b) -> a -> b
$ Meta -> [Inline]
docDate Meta
meta) Meta
meta
  Context Text
metadata <- WriterOptions
-> ([Block] -> m (Doc Text))
-> ([Inline] -> m (Doc Text))
-> Meta
-> m (Context Text)
forall (m :: * -> *) a.
(Monad m, TemplateTarget a) =>
WriterOptions
-> ([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a))
-> Meta
-> m (Context a)
metaToContext WriterOptions
opts
              ((Text -> Doc Text) -> m Text -> m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (m Text -> m (Doc Text))
-> ([Block] -> m Text) -> [Block] -> m (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterOptions -> Pandoc -> m Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeMarkdown WriterOptions
forall a. Default a => a
def (Pandoc -> m Text) -> ([Block] -> Pandoc) -> [Block] -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Meta -> [Block] -> Pandoc
Pandoc Meta
nullMeta)
              (\[Inline]
ils -> Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Doc Text) -> (Text -> Text) -> Text -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.stripEnd (Text -> Doc Text) -> m Text -> m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                WriterOptions -> Pandoc -> m Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeMarkdown WriterOptions
forall a. Default a => a
def (Meta -> [Block] -> Pandoc
Pandoc Meta
nullMeta [[Inline] -> Block
Plain [Inline]
ils]))
              Meta
meta'
  let blocks' :: [Block]
blocks' = Bool -> Maybe Int -> [Block] -> [Block]
makeSections Bool
False (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) [Block]
blocks
  Text
main <- Maybe Int -> Doc Text -> Text
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
colwidth (Doc Text -> Text)
-> ([Doc Text] -> Doc Text) -> [Doc Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> Text) -> m [Doc Text] -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
             (Block -> m (Doc Text)) -> [Block] -> m [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> Block -> m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> m (Doc Text)
blockToOPML WriterOptions
opts) [Block]
blocks'
  let context :: Context Text
context = Text -> Text -> Context Text -> Context Text
forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"body" Text
main Context Text
metadata
  Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$
    (if WriterOptions -> Bool
writerPreferAscii WriterOptions
opts then Text -> Text
toEntities else Text -> Text
forall a. a -> a
id) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
    case WriterOptions -> Maybe (Template Text)
writerTemplate WriterOptions
opts of
       Maybe (Template Text)
Nothing  -> Text
main
       Just Template Text
tpl -> Maybe Int -> Doc Text -> Text
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
colwidth (Doc Text -> Text) -> Doc Text -> Text
forall a b. (a -> b) -> a -> b
$ Template Text -> Context Text -> Doc Text
forall a b.
(TemplateTarget a, ToContext a b) =>
Template a -> b -> Doc a
renderTemplate Template Text
tpl Context Text
context


writeHtmlInlines :: PandocMonad m => [Inline] -> m Text
writeHtmlInlines :: [Inline] -> m Text
writeHtmlInlines [Inline]
ils =
  Text -> Text
T.strip (Text -> Text) -> m Text -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> Pandoc -> m Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
forall a. Default a => a
def (Meta -> [Block] -> Pandoc
Pandoc Meta
nullMeta [[Inline] -> Block
Plain [Inline]
ils])

-- date format: RFC 822: Thu, 14 Jul 2005 23:41:05 GMT
showDateTimeRFC822 :: UTCTime -> Text
showDateTimeRFC822 :: UTCTime -> Text
showDateTimeRFC822 = String -> Text
T.pack (String -> Text) -> (UTCTime -> String) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%a, %d %b %Y %X %Z"

convertDate :: [Inline] -> Text
convertDate :: [Inline] -> Text
convertDate [Inline]
ils = Text -> (UTCTime -> Text) -> Maybe UTCTime -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" UTCTime -> Text
showDateTimeRFC822 (Maybe UTCTime -> Text) -> Maybe UTCTime -> Text
forall a b. (a -> b) -> a -> b
$
  Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%F" (String -> Maybe UTCTime)
-> (Text -> String) -> Text -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Maybe UTCTime) -> Maybe Text -> Maybe UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Maybe Text
normalizeDate ([Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify [Inline]
ils)

-- | Convert a Block to OPML.
blockToOPML :: PandocMonad m => WriterOptions -> Block -> m (Doc Text)
blockToOPML :: WriterOptions -> Block -> m (Doc Text)
blockToOPML WriterOptions
opts (Div (Text
_,Text
"section":[Text]
_,[(Text, Text)]
_) (Header Int
_ (Text, [Text], [(Text, Text)])
_ [Inline]
title : [Block]
xs)) = do
  let isSect :: Block -> Bool
isSect (Div (Text
_,Text
"section":[Text]
_,[(Text, Text)]
_) (Header{}:[Block]
_)) = Bool
True
      isSect Block
_ = Bool
False
  let ([Block]
blocks, [Block]
rest) = (Block -> Bool) -> [Block] -> ([Block], [Block])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Block -> Bool
isSect [Block]
xs
  Text
htmlIls <- [Inline] -> m Text
forall (m :: * -> *). PandocMonad m => [Inline] -> m Text
writeHtmlInlines [Inline]
title
  Text
md <- if [Block] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
blocks
        then Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
forall a. Monoid a => a
mempty
        else WriterOptions -> Pandoc -> m Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeMarkdown WriterOptions
forall a. Default a => a
def (Pandoc -> m Text) -> Pandoc -> m Text
forall a b. (a -> b) -> a -> b
$ Meta -> [Block] -> Pandoc
Pandoc Meta
nullMeta [Block]
blocks
  let attrs :: [(Text, Text)]
attrs = (Text
"text", Text
htmlIls) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:
              [(Text
"_note", Text -> Text
T.stripEnd Text
md) | Bool -> Bool
not ([Block] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
blocks)]
  Doc Text
rest' <- [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> Doc Text) -> m [Doc Text] -> m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Block -> m (Doc Text)) -> [Block] -> m [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> Block -> m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> m (Doc Text)
blockToOPML WriterOptions
opts) [Block]
rest
  Doc Text -> m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> m (Doc Text)) -> Doc Text -> m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"outline" [(Text, Text)]
attrs Doc Text
rest'
blockToOPML WriterOptions
_ Block
_ = Doc Text -> m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty