    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE CPP               #-}
    {- |
       Module      : Text.Pandoc.Writers.OPML
       Copyright   : Copyright (C) 2013-2024 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 :: forall (m :: * -> *).
    PandocMonad m =>
    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
    forall b. ToMetaValue b => Text -> b -> Meta -> Meta
    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
      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 a b. (a -> b) -> m a -> m b
    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
    opts (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
    opts (Meta -> [Block] -> Pandoc
    Pandoc Meta
    nullMeta [[Inline] -> Block
    Plain [Inline]
    ils]))
                  Meta
    meta'
      let blocks' = Bool -> Maybe Int -> [Block] -> [Block]
    makeSections Bool
    False (Int -> Maybe Int
    forall a. a -> Maybe a
    Just Int
    1) [Block]
    blocks
      main <- render colwidth . vcat <$>
                 mapM (blockToOPML opts) blocks'
      let 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
      return $
        (if writerPreferAscii opts then toEntities else id) $
        case writerTemplate 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

    writeMarkdown' :: PandocMonad m => WriterOptions -> Pandoc -> m Text
    writeMarkdown' :: forall (m :: * -> *).
    PandocMonad m =>
    WriterOptions -> Pandoc -> m Text
    writeMarkdown' WriterOptions
    opts = WriterOptions -> Pandoc -> m Text
    forall (m :: * -> *).
    PandocMonad m =>
    WriterOptions -> Pandoc -> m Text
    writeMarkdown WriterOptions
    forall a. Default a => a
    def{ writerWrapText = writerWrapText opts
                                           , writerColumns = writerColumns opts
                                           , writerExtensions = pandocExtensions
                                           }

    writeHtmlInlines :: PandocMonad m => [Inline] -> m Text
    writeHtmlInlines :: forall (m :: * -> *). PandocMonad m => [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 :: forall (m :: * -> *).
    PandocMonad m =>
    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
      htmlIls <- [Inline] -> m Text
    forall (m :: * -> *). PandocMonad m => [Inline] -> m Text
    writeHtmlInlines [Inline]
    title
      md <- if null blocks
            then return mempty
            else writeMarkdown' opts $ Pandoc nullMeta blocks
      let 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 a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Block]
    blocks)]
      rest' <- vcat <$> mapM (blockToOPML opts) rest
      return $ inTags True "outline" attrs rest'
    blockToOPML WriterOptions
    _ Block
    _ = Doc Text -> m (Doc Text)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Doc Text
    forall a. Doc a
    empty